fradrive/src/Handler/Utils/Communication.hs

module Handler.Utils.Communication
  ( RecipientGroup(..)
  , CommunicationRoute(..)
  , Communication(..)
  , commR
  -- * Re-Exports
  , Job(..)
  ) where

import Import
import Handler.Utils

import Jobs.Queue

import qualified Database.Esqueleto as E
import qualified Data.CaseInsensitive as CI
import Data.Map ((!), (!?))
import qualified Data.Map as Map
import qualified Data.Set as Set


data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors
                    | RGTutorialParticipants
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe RecipientGroup
instance Finite RecipientGroup
nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''RecipientGroup id

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  } ''RecipientGroup


data RecipientCategory
  = RecipientGroup RecipientGroup
  | RecipientCustom
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

deriveFinite ''RecipientCategory
finiteEnum ''RecipientCategory

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , unwrapUnaryRecords = True
  , sumEncoding = UntaggedValue
  } ''RecipientCategory

instance ToJSONKey RecipientCategory where
  toJSONKey = toJSONKeyText toPathPiece
instance FromJSONKey RecipientCategory where
  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not pars RecipientCategory") return . fromPathPiece

instance PathPiece RecipientCategory where
  toPathPiece RecipientCustom    = "custom"
  toPathPiece (RecipientGroup g) = toPathPiece g

  fromPathPiece = finiteFromPathPiece

instance RenderMessage UniWorX RecipientCategory where
  renderMessage foundation ls = \case
    RecipientCustom  -> renderMessage' MsgRecipientCustom
    RecipientGroup g -> renderMessage' g
    where
      renderMessage' :: forall msg. RenderMessage UniWorX msg => msg -> Text
      renderMessage' = renderMessage foundation ls


data CommunicationRoute = CommunicationRoute
  { crRecipients    :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
  , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion
  , crJobs          :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
  , crHeading       :: SomeMessage UniWorX
  , crUltDest       :: SomeRoute UniWorX
  }

data Communication = Communication
 { cRecipients :: Set (Either UserEmail UserId)
 , cSubject :: Maybe Text
 , cBody :: Html
 }


commR :: CommunicationRoute -> Handler Html
commR CommunicationRoute{..} =  do
  cUser <- maybeAuth

  MsgRenderer mr <- getMsgRenderer
  mbCurrentRoute <- getCurrentRoute

  (suggestedRecipients, chosenRecipients) <- runDB $ do
    suggested <- for crRecipients $ \user -> E.select user

    let
      decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
      decrypt' cID = do
        uid <- decrypt cID
        whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
        getEntity uid

    chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient

    return (suggested, chosen')

  let
    lookupUser :: UserId -> User
    lookupUser lId
      = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (Map.elems suggestedRecipients) ++ chosenRecipients

  let chosenRecipients' = Map.fromList $
        [ ( (EnumPosition $ RecipientGroup g, pos)
          , (Right recp, recp `elem` map entityKey chosenRecipients)
          )
        | (g, recps) <- Map.toList suggestedRecipients
        , (pos, recp) <- zip [0..] $ map entityKey recps
        ] ++
        [ ( (EnumPosition   RecipientCustom, pos)
          , (Right recp, True)
          )
        | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ Map.elems suggestedRecipients)
        ]
      activeCategories = map RecipientGroup (Map.keys suggestedRecipients) `snoc` RecipientCustom

  let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
      recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
        where
          miAdd (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
            (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
            let
              addRes' = addRes <&> \(Set.toList -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) nEmails
            return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
          miAdd _ _ _ _ = Nothing
          miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
            (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
            return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
          miCell _ (Right (lookupUser -> User{..})) initRes nudge csrf = do
            (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
            return (tickRes, $(widgetFile "widgets/communication/recipientName"))
          miAllowAdd (EnumPosition RecipientCustom, 0) 1 _ = True
          miAllowAdd _ _ _ = False
          miAddEmpty _ 0 _ = Set.singleton (EnumPosition RecipientCustom, 0)
          miAddEmpty _ _ _ = Set.empty
          miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
          miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
          miLayout :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength
                   -> Map (EnumPosition RecipientCategory, ListPosition) (_, FormResult Bool)
                   -> Map (EnumPosition RecipientCategory, ListPosition) Widget
                   -> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX)
                   -> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget
                   -> Widget
          miLayout liveliness cState cellWdgts _delButtons addWdgts = do
            checkedIdentBase <- newIdent
            let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState
                checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
                hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts
                categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
            $(widgetFile "widgets/communication/recipientLayout")
          miDelete :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
          -- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos
          miDelete _ _ = mzero
          miIdent :: Text
          miIdent = "recipients"
          postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
          postProcess = Set.fromList . map fst . filter snd . Map.elems

  recipientsListMsg <- messageI Info MsgCommRecipientsList

  ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication
    <$> recipientAForm
    <*  aformMessage recipientsListMsg
    <*> aopt textField (fslI MsgCommSubject) Nothing
    <*> areq htmlField (fslI MsgCommBody) Nothing
  formResult commRes $ \comm -> do
    runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs
    addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
    redirect crUltDest


  let formWdgt = wrapForm commWdgt def
        { formMethod   = POST
        , formAction   = SomeRoute <$> mbCurrentRoute
        , formEncoding = commEncoding
        }
  siteLayoutMsg crHeading $ do
    setTitleI crHeading
    formWdgt