239 lines
11 KiB
Haskell
239 lines
11 KiB
Haskell
module Handler.Utils.Communication
|
|
( RecipientGroup(..)
|
|
, CommunicationRoute(..)
|
|
, Communication(..)
|
|
, commR
|
|
, crJobsCourseCommunication, crTestJobsCourseCommunication
|
|
-- * Re-Exports
|
|
, Job(..)
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
|
|
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 | RGCourseUnacceptedApplicants
|
|
| RGTutorialParticipants CryptoUUIDTutorial
|
|
| RGExamRegistered CryptoUUIDExam
|
|
| RGSheetSubmittor CryptoUUIDSheet
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
instance LowerBounded RecipientGroup where
|
|
minBound' = RGCourseParticipants
|
|
|
|
derivePathPiece ''RecipientGroup (camelToPathPiece' 1) "--"
|
|
pathPieceJSON ''RecipientGroup
|
|
|
|
|
|
data RecipientCategory
|
|
= RecipientGroup RecipientGroup
|
|
| RecipientCustom
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
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, Typeable)
|
|
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 :: 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, crTestJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
, crHeading :: SomeMessage UniWorX
|
|
, crUltDest :: SomeRoute UniWorX
|
|
}
|
|
|
|
data Communication = Communication
|
|
{ cRecipients :: Set (Either UserEmail UserId)
|
|
, cSubject :: Maybe Text
|
|
, cBody :: Html
|
|
}
|
|
|
|
|
|
crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
|
crJobsCourseCommunication jCourse Communication{..} = do
|
|
jSender <- requireAuthId
|
|
let jSubject = cSubject
|
|
jMailContent = cBody
|
|
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
|
|
jMailObjectUUID <- liftIO getRandom
|
|
jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
|
|
Left email -> return . Address Nothing $ CI.original email
|
|
Right rid -> userAddress <$> getJust rid
|
|
forM_ allRecipients $ \jRecipientEmail ->
|
|
yield JobSendCourseCommunication{..}
|
|
crTestJobsCourseCommunication jCourse comm = do
|
|
jSender <- requireAuthId
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let comm' = comm { cSubject = Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject) $ cSubject comm }
|
|
crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail)
|
|
|
|
|
|
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 $
|
|
[ ( (BoundedPosition $ RecipientGroup g, pos)
|
|
, (Right recp, recp `elem` map entityKey chosenRecipients)
|
|
)
|
|
| (g, recps) <- Map.toList suggestedRecipients
|
|
, (pos, recp) <- zip [0..] $ map entityKey recps
|
|
] ++
|
|
[ ( (BoundedPosition 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 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 -> User{..})) 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
|
|
|
|
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication
|
|
<$> recipientAForm
|
|
<* aformMessage recipientsListMsg
|
|
<*> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing
|
|
<*> (markupOutput <$> areq htmlField (fslI MsgCommBody) 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 crHeading
|
|
let commTestTip = $(i18nWidgetFile "comm-test-tip")
|
|
[whamlet|
|
|
$newline never
|
|
<section>
|
|
^{formWdgt}
|
|
<section .explanation>
|
|
^{commTestTip}
|
|
|]
|