-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Communication ( RecipientGroup(..) , CommunicationRoute(..) , Communication(..) , commR , crJobsCourseCommunication, crTestJobsCourseCommunication , crJobsFirmCommunication, crTestFirmCommunication -- * Re-Exports , Job(..) ) where import Import import Handler.Utils import Handler.Utils.Users import Jobs.Queue import qualified Database.Esqueleto.Legacy as E import qualified Data.CaseInsensitive as CI import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Conduit.Combinators as C data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGCourseParticipantsInTutorial | RGCourseUnacceptedApplicants -- WARNING: no RenderMessage instance, but a pattern match in templates/widgets/communication/recipientLayout.hamlet that needs to be extended | RGTutorialParticipants CryptoUUIDTutorial | RGExamRegistered CryptoUUIDExam | RGSheetSubmittor CryptoUUIDSheet | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand | RGFirmIndependent deriving (Eq, Ord, Read, Show, Generic) instance LowerBounded RecipientGroup where minBound' = RGCourseParticipants derivePathPiece ''RecipientGroup (camelToPathPiece' 1) "--" pathPieceJSON ''RecipientGroup data RecipientCategory = RecipientGroup RecipientGroup | RecipientCustom deriving (Eq, Ord, Read, Show, Generic) instance LowerBounded RecipientCategory where minBound' = RecipientGroup minBound' instance PathPiece RecipientCategory where toPathPiece RecipientCustom = "custom" toPathPiece (RecipientGroup g) = toPathPiece g fromPathPiece "custom" = Just RecipientCustom fromPathPiece t = RecipientGroup <$> fromPathPiece t pathPieceJSON ''RecipientCategory pathPieceJSONKey ''RecipientCategory data CommunicationButton = BtnCommunicationSend | BtnCommunicationTest deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) nullaryPathPiece ''CommunicationButton $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''CommunicationButton id makePrisms ''CommunicationButton instance Button UniWorX CommunicationButton where btnClasses BtnCommunicationSend = [BCIsButton, BCPrimary] btnClasses BtnCommunicationTest = [BCIsButton] data CommunicationRoute = CommunicationRoute { crRecipients :: [(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, crTestJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crHeading :: SomeMessage UniWorX , crTitle :: SomeMessage UniWorX , crUltDest :: SomeRoute UniWorX } data Communication = Communication { cRecipients :: Set (Either UserEmail UserId) , cContent :: CommunicationContent } makeLenses_ ''Communication crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsCourseCommunication jCourse Communication{..} = do jSender <- requireAuthId jMailObjectUUID <- liftIO getRandom let jMailContent = cContent (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails netReceiverAddresses <- lift $ do netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) forM_ jAllRecipientAddresses $ \raddr -> yield JobSendCourseCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email crTestJobsCourseCommunication jCourse comm = do jSender <- requireAuthId MsgRenderer mr <- getMsgRenderer let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject) crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) crJobsFirmCommunication, crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsFirmCommunication jCompanies Communication{..} = do jSender <- requireAuthId jMailObjectUUID <- liftIO getRandom let jMailContent = cContent (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails netReceiverAddresses <- lift $ do netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) forM_ jAllRecipientAddresses $ \raddr -> yield JobSendFirmCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email crTestFirmCommunication jCompanies comm = do jSender <- requireAuthId MsgRenderer mr <- getMsgRenderer let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject) crJobsFirmCommunication jCompanies comm' .| C.filter ((== Right jSender) . jRecipientEmail) commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do let decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User)) decrypt' cID = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) getEntity uid cUser <- maybeAuth (chosenRecipients, suggestedRecipients) <- runDB $ (,) <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)) <*> (filter (notNull . snd) <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry)) $logWarnS "COMM" ("Communication handlerwith (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") MsgRenderer mr <- getMsgRenderer mbCurrentRoute <- getCurrentRoute globalCC <- getsYesod $ view _appCommunicationGlobalCC let lookupUser :: UserId -> (UserDisplayName,UserSurname) lookupUser = let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) in usrNames . flip Map.lookup usrMap chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) , (Right recp, recp `elem` map entityKey chosenRecipients) ) | (g, recps) <- suggestedRecipients , (pos, recp) <- zip [0..] $ map entityKey recps ] ++ [ ( (BoundedPosition RecipientCustom, pos) , (recp, True) ) | (pos, recp) <- zip [0..] ( mcons (Left <$> globalCC) (Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients))) ) ] activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') where miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing let addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails 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 uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do (tickRes, tickView) <- if | fmap entityKey cUser == Just uid -> mforced checkBoxField ("" & addName (nudge "tick")) True | otherwise -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True return (tickRes, $(widgetFile "widgets/communication/recipientName")) miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True miAllowAdd _ _ _ = False miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) miAddEmpty _ _ _ = Set.empty miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) -> Map (BoundedPosition RecipientCategory, ListPosition) Widget -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget -> Widget miLayout liveliness cState cellWdgts _delButtons addWdgts = do checkedIdentBase <- newIdent let checkedCategories = Set.mapMonotonic (unBoundedPosition . 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, (BoundedPosition c, 0)) addWdgts categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget rgTutorialParticipantsCaption cID = do tutId <- decrypt cID Tutorial{..} <- liftHandler . runDBRead $ get404 tutId i18n $ MsgRGTutorialParticipants tutorialName rgExamRegisteredCaption :: CryptoUUIDExam -> Widget rgExamRegisteredCaption cID = do eId <- decrypt cID Exam{..} <- liftHandler . runDBRead $ get404 eId i18n $ MsgRGExamRegistered examName rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget rgSheetSubmittorCaption cID = do sId <- decrypt cID Sheet{..} <- liftHandler . runDBRead $ get404 sId i18n $ MsgRGSheetSubmittor sheetName $(widgetFile "widgets/communication/recipientLayout") miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos miDelete _ _ = mzero miIdent :: Text miIdent = "recipients" postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) postProcess = Set.fromList . map fst . filter snd . Map.elems recipientsListMsg <- messageI Info MsgCommRecipientsList attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize let attachmentField = genericFileField $ return FileField { fieldIdent = Nothing , fieldUnpackZips = FileFieldUserOption True False , fieldMultiple = True , fieldRestrictExtensions = Nothing , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldAllEmptyOk = True } ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg <*> ( CommunicationContent <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) ) formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm redirect crUltDest (comm, BtnCommunicationTest) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs addMessageI Info MsgCommTestSuccess let formWdgt = wrapForm commWdgt def { formMethod = POST , formAction = SomeRoute <$> mbCurrentRoute , formEncoding = commEncoding , formSubmit = FormNoSubmit } siteLayoutMsg crHeading $ do setTitleI crTitle let commTestTip = $(i18nWidgetFile "comm-test-tip") [whamlet| $newline never
^{formWdgt}
^{commTestTip} |]