email page form incomplete

messages/uniworx/de.msg

@@ -730,3 +730,9 @@ MassInputAddDimension: Hinzufügen
 MassInputDeleteCell: Entfernen
 
 NavigationFavourites: Favoriten
+
+CommSubject: Betreff
+CommRecipients: Empfänger
+
+AddRecipientGroups: Empfängergruppen
+AddRecipientCustom: Weitere Empfänger

routes

@@ -78,6 +78,7 @@
   /users                      CUsersR         GET POST
   /users/#CryptoUUIDUser      CUserR          GET POST        !lecturerANDparticipant
   /correctors                 CHiWisR         GET
+  /mail                       CCommR          GET POST
   /notes                      CNotesR         GET POST        !corrector
   /subs                       CCorrectionsR   GET POST
   /ex                         SheetListR      GET             !registered !materials !corrector

src/Handler/Course.hs

@@ -821,7 +821,7 @@ colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDeg
     foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
 
 
-data CourseUserAction = CourseUserDeregister
+data CourseUserAction = CourseUserSendMail | CourseUserDeregister
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 instance Universe CourseUserAction
@@ -915,6 +915,9 @@ postCUsersR tid ssh csh = do
     table <- makeCourseUserTable cid colChoices psValidator
     return (ent, numParticipants, table)
   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])
     (CourseUserDeregister,selectedUsers) -> do
         nrDel <- runDB $ deleteWhereCount
           [ CourseParticipantCourse ==. cid
@@ -1026,3 +1029,9 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 -- If they are shared, adjust MsgCourseUserNoteTooltip
 getCNotesR  = error "CNotesR: Not implemented"
 postCNotesR = error "CNotesR: Not implemented"
+
+
+
+getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCCommR = postCCommR
+postCCommR tid ssh csh = commR _hole

src/Handler/Utils/Communication.hs

@@ -0,0 +1,88 @@
+module Handler.Utils.Communication where
+
+import Import
+
+import qualified Database.Esqueleto as E
+
+data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe RecipientGroup
+instance Finite RecipientGroup
+nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''RecipientGroup id
+
+
+data RecipientAddOptions
+  = AddRecipientGroups
+  | AddRecipientGroup RecipientGroup
+  | AddRecipientCustom
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Universe RecipientAddOptions where
+  universe = AddRecipientGroups:
+             [AddRecipientGroup g | g <- universe]
+             ++ [AddRecipientCustom]
+instance Finite RecipientAddOptions
+
+instance PathPiece RecipientAddOption where
+  toPathPiece AddRecipientGroups    = "recipient-groups"
+  toPathPiece AddRecipientCustom    = "recipient-custom"
+  toPathPiece (AddRecipientGroup g) = toPathPiece g
+
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX RecipientAddOption where
+  renderMessage foundation ls = \case
+    AddRecipientGroups  -> renderMessage' MsgAddRecipientGroups
+    AddRecipientCustom  -> renderMessage' MsgAddRecipientCustom
+    AddRecipientGroup g -> renderMessage' g
+    where renderMessage' = renderMessage foundation ls
+
+
+data CommunicationRoute = CommuncationRoute
+  { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
+  , crJob        :: MailT Handler () -> Handler Job
+  }
+
+data Communication = Communication
+ { cRecipients :: Set (Either Email UserId)
+ , cSubject :: Text
+ }
+
+
+
+commR :: CommunicationRoute -> Handler Html
+commR CommunicationRoute{..} =  do
+  MsgRenderer mr <- getMsgRenderer
+
+  suggestedRecipients' <- runDB $ traverse E.select crRecipients
+  suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> encrypt rid <*> pure ent
+
+  let recipientAForm :: AForm (Set (Either Email UserId))
+      recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True Nothing
+        where miAdd _ _ nudge submitButton = Just $ \csrf -> do
+                let addOptions = Map.fromList . concat $
+                      [ pure (AddRecipientGroups, apreq (selectField . return $ mkOptionsList
+                              [ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ]
+                          ) )
+                      , do
+                          (g,recs) <- Map.toList suggestedRecipients
+                          return ( AddRecipientGroup g
+                                 , apreq (selectField . return $ mkOptionsList
+                                     [ Option userDisplayName (Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ]
+                                 )
+                      -- , pure (AddRecipientCustom, _ )
+                      ]
+
+
+                multiAction ()
+              miCell
+              miDelete
+              miAllowAdd
+              miButtonAction
+
+  runFormPost . identifyForm FIDCommunication $ renderAForm FormStandard $ Communication
+    <$> recipientAForm
+    <*> areq textField (fslI MsgCommSubject) Nothing
+

src/Handler/Utils/Form/MassInput.hs

@@ -3,10 +3,11 @@
 module Handler.Utils.Form.MassInput
   ( MassInput(..)
   , massInput
-  , massInputList
   , BoxDimension(..)
   , IsBoxCoord(..), boxDimension
   , Liveliness(..)
+  , massInputA
+  , massInputList
   , ListLength(..), ListPosition(..), miDeleteList
   ) where
 
@@ -393,3 +394,17 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes
   miSettings
   miRequired
   (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
+
+massInputA :: forall handler cellData cellResult liveliness.
+           ( MonadHandler handler, HandlerSite handler ~ UniWorX
+           , ToJSON cellData, FromJSON cellData
+           , Liveliness liveliness
+           , MonadLogger handler
+           )
+          => MassInput handler liveliness cellData cellResult
+          -> FieldSettings UniWorX
+          -> Bool -- ^ Required?
+          -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
+          -> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult))
+massInputA  mi fs fvRequired initialResult = formToAForm $
+  over _2 pure <$> massInput mi fs fvRequired initialResult mempty

src/Utils/Form.hs

@@ -189,6 +189,7 @@ data FormIdentifier
   | FIDcUserNote
   | FIDAdminDemo
   | FIDUserDelete
+  | FIDCommunication
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where

src/Utils/Parameters.hs

@@ -20,7 +20,7 @@ import Data.Universe
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
-data GlobalGetParam = GetReferer
+data GlobalGetParam = GetReferer | GetRecipient
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalGetParam