email page form incomplete

messages/uniworx/de.msg

@@ -729,4 +729,10 @@ DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus de
 MassInputAddDimension: Hinzufügen
 MassInputDeleteCell: Entfernen
 
-NavigationFavourites: Favoriten
+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
 
@@ -33,7 +34,7 @@ import Control.Monad.Reader.Class (MonadReader(local))
 
 
 data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
-  
+
 class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where
   boxDimensions :: [BoxDimension x]
   boxOrigin :: x
@@ -47,7 +48,7 @@ boxDimension n
 
 -- zeroDimension :: IsBoxCoord x => Natural -> x -> x
 -- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
-  
+
 class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
   type BoxCoord a :: *
   liveCoords :: Prism' (Set (BoxCoord a)) a
@@ -221,12 +222,12 @@ massInput :: forall handler cellData cellResult liveliness.
           -> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX))
 massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
   let initialShape = fmap fst <$> initialResult
-  
+
   miName <- maybe newFormIdent return fsName
   fvId <- maybe newIdent return fsId
   miAction <- traverse toTextUrl $ miButtonAction fvId
   let addFormAction = maybe id (addAttr "formaction") miAction
-  
+
   let
     shapeName :: MassInputFieldName (BoxCoord liveliness)
     shapeName = MassInputShape{..}
@@ -303,8 +304,8 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
   let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
 
   shape <- if
-    | Just s <- addShape -> return s 
+    | Just s <- addShape -> return s
-    | Just s <- delShape -> return s 
+    | Just s <- delShape -> return s
     | otherwise          -> return sentShape'
   liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
 
@@ -349,7 +350,7 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
             cells
               | [] <- remDims = do
                   coord <- coords
-                  Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults 
+                  Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults
                   let deleteButton = snd <$> Map.lookup coord delResults
                   return (coord, $(widgetFile "widgets/massinput/cell"))
               | otherwise =
@@ -360,7 +361,7 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
       miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions
 
   MsgRenderer mr <- getMsgRenderer
-  
+
   let
     fvLabel = toHtml $ mr fsLabel
     fvTooltip = toHtml . mr <$> fsTooltip
@@ -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