diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 44fad53b3..6f05189db 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -114,6 +114,7 @@ CourseUserNoteSaved: Notizänderungen gespeichert CourseUserNoteDeleted: Teilnehmernotiz gelöscht CourseUserDeregister: Abmelden CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet +CourseUserSendMail: Mitteilung verschicken CourseLecturers: Kursverwalter CourseLecturer: Dozent @@ -738,6 +739,10 @@ NavigationFavourites: Favoriten CommSubject: Betreff CommRecipients: Empfänger +CommDuplicateRecipients recipients@TextList: #{pluralDE (length recipients) "Doppelter" "Doppelte"} Empfänger: #{intercalate ", " recipients} +CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt + +CommCourseHeading: Kursmitteilung AddRecipientGroups: Empfängergruppen AddRecipientCustom: Weitere Empfänger diff --git a/src/Foundation.hs b/src/Foundation.hs index f85e69e54..d7b14c2f9 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -173,8 +173,9 @@ noneOneMoreDE num noneText singularForm pluralForm | num == 1 = singularForm | otherwise = pluralForm --- Convenience Type for Messages -type IntMaybe = Maybe Int -- Yesod messages cannot deal with compound type identifiers +-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers +type IntMaybe = Maybe Int +type TextList = [Text] -- | Convenience function for i18n messages definitions maybeDisplay :: DisplayAble m => Text -> Maybe m -> Text -> Text diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 42c21d62a..b82a85ea0 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -350,7 +350,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \frag -> do - (actionRes, action) <- multiAction actions Nothing + (actionRes, action) <- multiActionM actions "" Nothing mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = _1 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 00b51056f..0a780b9ad 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -9,6 +9,7 @@ import Utils.Form -- import Utils.DB import Handler.Utils import Handler.Utils.Course +import Handler.Utils.Communication import Handler.Utils.Form.MassInput import Handler.Utils.Delete import Handler.Utils.Database @@ -930,7 +931,7 @@ postCUsersR tid ssh csh = do formResult participantRes $ \case (CourseUserSendMail, selectedUsers) -> do cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] - redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cid) | cid <- cids]) + redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) (CourseUserDeregister,selectedUsers) -> do nrDel <- runDB $ deleteWhereCount [ CourseParticipantCourse ==. cid @@ -1047,4 +1048,32 @@ postCNotesR = error "CNotesR: Not implemented" getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCCommR = postCCommR -postCCommR tid ssh csh = commR _hole +postCCommR tid ssh csh = do + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + + commR CommunicationRoute + { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading + , crUltDest = SomeRoute $ CourseR tid ssh csh CCommR + , crJob = error "job undefined" + , crRecipients = Map.fromList + [ ( RGCourseParticipants + , E.from $ \(user `E.InnerJoin` participant) -> do + E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser + E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + return user + ) + , ( RGCourseLecturers + , E.from $ \(user `E.InnerJoin` lecturer) -> do + E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser + E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid + return user + ) + , ( RGCourseCorrectors + , E.from $ \user -> do + E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do + E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return user + ) + ] + } diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index d29b7f214..788310888 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -25,7 +25,7 @@ data HelpForm = HelpForm helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm helpForm mr mReferer mUid = HelpForm <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) - <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) + <*> multiActionA identActions (fslI MsgHelpAnswer) (HIUser <$ mUid) <*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing <*> (unTextarea <$> areq textareaField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing) where diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index c80ab32c0..8228136d4 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -217,7 +217,7 @@ postMessageListR = do , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now)) , (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing)) ] - (actionRes, action) <- multiAction actions (Just SMActivate) + (actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = id diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index fc07e9098..873781da7 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -1,17 +1,18 @@ module Handler.Utils.Communication where import Import -import Handler.Utils.Form +import Handler.Utils import Handler.Utils.Form.MassInput import Utils.Lens -import Jobs.Types +import Jobs.Queue +import Control.Monad.Trans.Reader (mapReaderT) import qualified Database.Esqueleto as E - +import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map import qualified Data.Set as Set - + data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) @@ -56,14 +57,16 @@ instance RenderMessage UniWorX RecipientAddOption where data CommunicationRoute = CommunicationRoute { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User))) , crJob :: Communication -> DB Job + , crHeading :: SomeMessage UniWorX + , crUltDest :: SomeRoute UniWorX } - -- `Communication` is defined in `Jobs.Types` commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do MsgRenderer mr <- getMsgRenderer + mbCurrentRoute <- getCurrentRoute suggestedRecipients' <- runDB $ traverse E.select crRecipients suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> (encrypt rid :: Handler CryptoUUIDUser) <*> pure ent @@ -86,20 +89,51 @@ commR CommunicationRoute{..} = do [ Option userDisplayName (Set.singleton $ Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ] ) ("" & addName (nudge . toPathPiece $ AddRecipientGroup g)) Nothing ) - -- , pure (AddRecipientCustom, _ ) + , pure ( AddRecipientCustom + , Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField ("" & addName (nudge $ toPathPiece AddRecipientCustom)) Nothing ) ] (addRes, addWdgt) <- multiActionM addOptions ("" & addName (nudge "select")) Nothing csrf - error "miAdd" :: MForm Handler (FormResult (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))), Widget) - miCell = error "miCell" + -- lookupUserDisplayName :: UserId -> UserDisplayName + lookupUserDisplayName <- liftHandlerT . runDB $ do + let uids = toListOf (_FormSuccess . folded . _Right) addRes + names <- forM uids getJustEntity + return $ \uid -> case filter ((== uid) . entityKey) names of + [Entity _ User{..}] -> userDisplayName + _other -> error "UserId lookpup failed" + let addRes' = addRes <&> \newSet oldMap -> if + | collisions <- newSet `Set.intersection` Set.fromList (Map.elems oldMap) + , not $ Set.null collisions -> + FormFailure [ mr . MsgCommDuplicateRecipients . map (either CI.original lookupUserDisplayName) $ Set.toList collisions ] + | otherwise -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList newSet + + addWdgt' = mconcat [ toWidget csrf, addWdgt, fvInput submitView ] + return (addRes', addWdgt') + + miCell _ (Left email) _ _nudge csrf + = return (pure (), toWidget csrf <> toWidget (mailtoHtml email)) + miCell _ (Right rid) _ _nudge csrf = do + User{..} <- liftHandlerT . runDB $ getJust rid + return (pure (), toWidget csrf <> nameEmailWidget userEmail userDisplayName userSurname) miDelete :: ListLength -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) -- This type signature is needed, so GHC can infer the type of @MassInput{..}@, above - miDelete = error "miDelete" - miAllowAdd = error "miAllowAdd" - miButtonAction = error "miButtonAction" + miDelete = miDeleteList -- default for lists suffices, since there are no restrictions + miAllowAdd _ _ _ = True + miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId) postProcess = Set.fromList . map fst . Map.elems - runFormPost . identifyForm FIDCommunication $ renderAForm FormStandard $ Communication + ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication <$> recipientAForm <*> aopt textField (fslI MsgCommSubject) Nothing + formResult commRes $ \comm -> do + runDBJobs $ queueDBJob =<< mapReaderT lift (crJob comm) + addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm + redirect crUltDest - error "commR" + + let formWdgt = wrapForm commWdgt def + { formMethod = POST + , formAction = SomeRoute <$> mbCurrentRoute + , formEncoding = commEncoding + } + siteLayoutMsg crHeading formWdgt