292 lines
15 KiB
Haskell
292 lines
15 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- 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
|
|
maybeMapM getEmailAddressFor 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
|
|
maybeMapM getEmailAddressFor 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
|
|
<section>
|
|
^{formWdgt}
|
|
<section .explanation>
|
|
^{commTestTip}
|
|
|]
|