communication prototype

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

src/Foundation.hs

@@ -173,8 +173,9 @@ noneOneMoreDE num noneText singularForm pluralForm
   | num == 1  = singularForm
   | otherwise = pluralForm
 
--- Convenience Type for Messages
+-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
-type IntMaybe = Maybe Int -- 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

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

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
+        )
+      ]
+    }

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

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

src/Handler/Utils/Communication.hs

@@ -1,14 +1,15 @@
 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
 
@@ -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)
+            -- lookupUserDisplayName :: UserId -> UserDisplayName
-          miCell = error "miCell"
+            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"
+          miDelete = miDeleteList -- default for lists suffices, since there are no restrictions
-          miAllowAdd = error "miAllowAdd"
+          miAllowAdd _ _ _ = True
-          miButtonAction = error "miButtonAction"
+          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