Merge branch '328-formular-zum-kontakt-mit-kursteilnehmern' into 'master'

Resolve "Formular zum Kontakt mit Kursteilnehmern"

Closes #328

See merge request !179

messages/uniworx/de.msg

@@ -117,6 +117,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
@@ -530,6 +531,7 @@ MailEditNotifications: Benachrichtigungen ein-/ausschalten
 MailSubjectSupport: Supportanfrage
 MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
 
+CommCourseSubject: Kursmitteilung
 MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter
 CourseLecturerInvitationAcceptDecline: Einladung annehmen/ablehnen
 
@@ -687,6 +689,7 @@ MenuLogin: Login
 MenuLogout: Logout
 MenuCourseList: Kurse
 MenuCourseMembers: Kursteilnehmer
+MenuCourseCommunication: Kursmitteilung
 MenuTermShow: Semester
 MenuSubmissionDelete: Abgabe löschen
 MenuUsers: Benutzer
@@ -757,6 +760,23 @@ MassInputDeleteCell: Entfernen
 
 NavigationFavourites: Favoriten
 
+CommSubject: Betreff
+CommBody: Nachricht
+CommRecipients: Empfänger
+CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht.
+CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert
+CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt
+
+CommCourseHeading: Kursmitteilung
+
+RecipientCustom: Weitere Empfänger
+
+RGCourseParticipants: Kursteilnehmer
+RGCourseLecturers: Kursverwalter
+RGCourseCorrectors: Korrektoren
+
+MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg)
+MultiEmailFieldTip: Je nach Browser sind mehrere komma-separierte E-Mail-Addressen möglich
 EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt.
 
 LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen

routes

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

src/Data/Set/Instances.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Set.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+
+instance (Ord a, Hashable a) => Hashable (Set a) where
+  hashWithSalt s xs = hashWithSalt s $ Set.toAscList xs

src/Data/Universe/TH.hs

@@ -0,0 +1,69 @@
+module Data.Universe.TH
+  ( finiteEnum
+  , deriveUniverse
+  , deriveFinite
+  ) where
+
+import Prelude
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
+
+import Data.Universe
+import Data.Universe.Helpers (interleave)
+
+import Control.Monad (unless)
+
+import Data.List (elemIndex)
+
+
+finiteEnum :: Name -> DecsQ
+-- ^ Declare generic `Enum`- and `Bounded`-Instances given `Finite`- and `Eq`-Instances
+finiteEnum tName = do
+  DatatypeInfo{..} <- reifyDatatype tName
+
+  let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars
+      tUniverse = [e|universeF :: [$(datatype)]|]
+  
+  [d|
+    instance Bounded $(datatype) where
+      minBound = head $(tUniverse)
+      maxBound = last $(tUniverse)
+
+    instance Enum $(datatype) where
+      toEnum n
+        | n >= 0
+        , n < length $(tUniverse)
+        = $(tUniverse) !! n
+        | otherwise = error $ "toEnum " ++ $(stringE $ nameBase tName) ++ ": out of bounds"
+      fromEnum = fromMaybe (error $ "fromEnum " ++ $(stringE $ nameBase tName) ++ ": invalid `universeF`") . flip elemIndex $(tUniverse)
+
+      enumFrom x = map toEnum [fromEnum x .. fromEnum (maxBound :: $(datatype))]
+      enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. fromEnum (maxBound :: $(datatype))]
+    |]
+
+deriveUniverse, deriveFinite :: Name -> DecsQ
+deriveUniverse = deriveUniverse' [e|interleave|] [e|universe|]
+deriveFinite tName = fmap concat . sequence $
+  [ deriveUniverse' [e|concat|] [e|universeF|] tName
+  , do
+      DatatypeInfo{..} <- reifyDatatype tName
+      [d|instance Finite $(foldl appT (conT datatypeName) $ map pure datatypeVars)|]
+  ]
+
+deriveUniverse' :: ExpQ -> ExpQ -> Name -> DecsQ
+deriveUniverse' interleaveExp universeExp tName = do
+  DatatypeInfo{..} <- reifyDatatype tName
+
+  let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars
+      consUniverse ConstructorInfo{..} = do
+        unless (null constructorVars) $
+          fail "Constructors with variables no supported"
+
+        foldl (\f t -> [e|ap|] `appE` f `appE` sigE universeExp (listT `appT` t)) [e|pure $(conE constructorName)|] $ map pure constructorFields
+
+  pure <$> instanceD (cxt []) [t|Universe $(datatype)|]
+    [ funD 'universe
+      [ clause [] (normalB . appE interleaveExp . listE $ map consUniverse datatypeCons) []
+      ]
+    ]

src/Foundation.hs

@@ -186,8 +186,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
@@ -1259,6 +1260,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen"    , Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu",         Just $ CourseR tid ssh csh SheetListR)
+  breadcrumb (CourseR tid ssh csh CCommR    ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR)
 
   breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
   breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit",    Just $ CSheetR tid ssh csh shn SShowR)
@@ -1636,6 +1638,14 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType = PageActionSecondary
+      , menuItemLabel = MsgMenuCourseCommunication
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   , MenuItem
       { menuItemType = PageActionSecondary
       , menuItemLabel = MsgMenuCourseEdit
@@ -2325,11 +2335,15 @@ instance YesodMail UniWorX where
     pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
     withResource pool act
   mailT ctx mail = defMailT ctx $ do
-    void setMailObjectId
+    void setMailObjectIdRandom
     setDateCurrent
     replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
 
-    mail <* setMailSmtpData
+    (mRes, smtpData) <- listen mail
+    unless (view _MailSmtpDataSet smtpData)
+      setMailSmtpData
+
+    return mRes
 
 
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where

src/Handler/Admin.hs

@@ -205,7 +205,7 @@ postAdminTestR = do
 
   -- The actual call to @massInput@ is comparatively simple:
 
-  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing
+  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout) "" True Nothing
 
 
   let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]

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
@@ -27,6 +28,7 @@ import Data.Monoid (Last(..))
 
 import Data.Maybe (fromJust)
 import qualified Data.Set as Set
+import Data.Map ((!))
 import qualified Data.Map as Map
 
 import qualified Database.Esqueleto as E
@@ -637,34 +639,18 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
                         | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
                 FormFailure errs -> FormFailure errs
                 FormMissing -> FormMissing
-              addView'  = toWidget csrf >> fvInput addView >> fvInput btn
+              addView' = $(widgetFile "course/lecturerMassInput/add")
           return (addRes'', addView')
 
         miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
         miCell _ (Right lid) defType nudge = \csrf -> do
           (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
           User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
-          let lrwView' = [whamlet|$newline never
+          let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
-                  #{csrf}
-                  ^{nameEmailWidget userEmail userDisplayName userSurname} #
-                  ^{fvInput lrwView}
-                |]
           return (Just <$> lrwRes,lrwView')
         miCell _ (Left lEmail) defType nudge = \csrf -> do
           (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
-          let lrwView' = [whamlet|
+          let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
-                           $newline never
-                           #{csrf}
-                           <span style="font-family:monospace">
-                             #{lEmail}
-                            #
-                           <div .tooltip>
-                             <div .tooltip__handle>
-                             <div .tooltip__content>
-                               _{MsgEmailInvitationWarning}
-                            #
-                           ^{fvInput lrwView}
-                         |]
           return (lrwRes,lrwView')
 
         miDelete :: ListLength   -- ^ Current shape
@@ -675,6 +661,17 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
         miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
         miAllowAdd _ _ _ = True
 
+        miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
+        miAddEmpty _ _ _ = Set.empty
+
+        miLayout :: ListLength
+                 -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
+                 -> Map ListPosition Widget -- ^ Cell widgets
+                 -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
+                 -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
+                 -> Widget
+        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
+
 
         lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
         lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
@@ -863,7 +860,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
@@ -970,6 +967,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
@@ -1083,6 +1083,53 @@ getCNotesR  = error "CNotesR: Not implemented"
 postCNotesR = error "CNotesR: Not implemented"
 
 
+getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCCommR = postCCommR
+postCCommR tid ssh csh = do
+  jSender <- requireAuthId
+  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+
+  commR CommunicationRoute
+    { crHeading    = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading
+    , crUltDest    = SomeRoute $ CourseR tid ssh csh CCommR
+    , crJobs       = \Communication{..} -> do
+        let jSubject = cSubject
+            jMailContent = cBody
+            jCourse = cid
+            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{..}
+    , 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
+        )
+      ]
+    , crRecipientAuth = Just $ \uid -> do
+        cID <- encrypt uid
+        evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
+    }
+
+ 
 data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 instance Universe ButtonLecInvite

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
@@ -53,8 +53,8 @@ postHelpR = do
     now <- liftIO getCurrentTime
     hfReferer' <- traverse toTextUrl hfReferer
     queueJob' JobHelpRequest
-      { jSender      = hfUserId
+      { jHelpSender  = hfUserId
-      , jHelpSubject = hfSubject
+      , jSubject     = hfSubject
       , jHelpRequest = hfRequest
       , jRequestTime = now
       , jReferer     = hfReferer'

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

@@ -0,0 +1,188 @@
+module Handler.Utils.Communication
+  ( RecipientGroup(..)
+  , CommunicationRoute(..)
+  , Communication(..)
+  , commR
+  -- * Re-Exports
+  , Job(..)
+  ) where
+
+import Import
+import Handler.Utils
+import Handler.Utils.Form.MassInput
+import Utils.Lens
+
+import Jobs.Queue
+import Control.Monad.Trans.Reader (mapReaderT)
+
+import qualified Database.Esqueleto as E
+import qualified Data.CaseInsensitive as CI
+import Data.Map ((!), (!?))
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Data.Aeson.TH
+import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
+
+import Data.List (nub)
+
+
+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
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''RecipientGroup
+
+
+data RecipientCategory
+  = RecipientGroup RecipientGroup
+  | RecipientCustom
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveFinite ''RecipientCategory
+finiteEnum ''RecipientCategory
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , unwrapUnaryRecords = True
+  , sumEncoding = UntaggedValue
+  } ''RecipientCategory
+
+instance ToJSONKey RecipientCategory where
+  toJSONKey = toJSONKeyText toPathPiece
+instance FromJSONKey RecipientCategory where
+  fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not pars RecipientCategory") return . fromPathPiece
+
+instance PathPiece RecipientCategory where
+  toPathPiece RecipientCustom    = "custom"
+  toPathPiece (RecipientGroup g) = toPathPiece g
+
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX RecipientCategory where
+  renderMessage foundation ls = \case
+    RecipientCustom  -> renderMessage' MsgRecipientCustom
+    RecipientGroup g -> renderMessage' g
+    where
+      renderMessage' :: forall msg. RenderMessage UniWorX msg => msg -> Text
+      renderMessage' = renderMessage foundation ls
+
+
+data CommunicationRoute = CommunicationRoute
+  { crRecipients    :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
+  , crRecipientAuth :: Maybe (UserId -> DB AuthResult)
+  , crJobs          :: Communication -> Source (YesodDB UniWorX) Job
+  , crHeading       :: SomeMessage UniWorX
+  , crUltDest       :: SomeRoute UniWorX
+  }
+
+data Communication = Communication
+ { cRecipients :: Set (Either UserEmail UserId)
+ , cSubject :: Maybe Text
+ , cBody :: Html
+ }
+
+
+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 $
+        [ ( (EnumPosition $ RecipientGroup g, pos)
+          , (Right recp, recp `elem` map entityKey chosenRecipients)
+          )
+        | (g, recps) <- Map.toList suggestedRecipients
+        , (pos, recp) <- zip [0..] $ map entityKey recps
+        ] ++
+        [ ( (EnumPosition   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 (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
+            (addRes, addView) <- mpreq multiEmailField (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
+            let
+              addRes' = addRes <&> \(nub . map CI.mk -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) (map Left nEmails)
+            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 (lookupUser -> User{..})) initRes nudge csrf = do 
+            (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
+            return (tickRes, $(widgetFile "widgets/communication/recipientName"))
+          miAllowAdd (EnumPosition RecipientCustom, 0) 1 _ = True
+          miAllowAdd _ _ _ = False
+          miAddEmpty _ 0 _ = Set.singleton (EnumPosition RecipientCustom, 0)
+          miAddEmpty _ _ _ = Set.empty
+          miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
+          miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
+          miLayout :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength
+                   -> Map (EnumPosition RecipientCategory, ListPosition) (_, FormResult Bool)
+                   -> Map (EnumPosition RecipientCategory, ListPosition) Widget
+                   -> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX)
+                   -> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget
+                   -> Widget
+          miLayout liveliness state cellWdgts _delButtons addWdgts = do
+            checkedIdentBase <- newIdent
+            let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || fromMaybe True (fmap snd $ chosenRecipients' !? k))) False state) $ Map.keysSet state
+                checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
+                categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
+            $(widgetFile "widgets/communication/recipientLayout")
+          miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
+          -- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos
+          miDelete _ _ = mzero
+          postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
+          postProcess = Set.fromList . map fst . filter snd . Map.elems
+
+  ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication
+    <$> recipientAForm
+    <*> aopt textField (fslI MsgCommSubject) Nothing
+    <*> areq htmlField (fslI MsgCommBody)    Nothing
+  formResult commRes $ \comm -> do
+    runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs
+    addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
+    redirect crUltDest
+
+
+  let formWdgt = wrapForm commWdgt def
+        { formMethod   = POST
+        , formAction   = SomeRoute <$> mbCurrentRoute
+        , formEncoding = commEncoding
+        }
+  siteLayoutMsg crHeading $ do
+    setTitleI crHeading
+    formWdgt

src/Handler/Utils/Form.hs

@@ -10,7 +10,7 @@ import Handler.Utils.Form.Types
 
 import Handler.Utils.DateTime
 
-import Import hiding (cons)
+import Import
 import qualified Data.Char as Char
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
@@ -377,7 +377,7 @@ nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
 embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
 
 sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
-sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
+sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
   where
     selOptions = Map.fromList
       [ ( Points',     Points     <$> maxPointsReq )
@@ -395,7 +395,7 @@ sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> tem
 
 
 sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
-sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
+sheetTypeAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
   where
     selOptions = Map.fromList
       [ ( Normal', Normal <$> gradingReq )
@@ -414,8 +414,8 @@ sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> templa
       NotGraded -> NotGraded'
 
 sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
-sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
+sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
-  let
+  where
     selOptions = Map.fromList
       [ ( Arbitrary', Arbitrary
           <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
@@ -423,25 +423,6 @@ sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
       , ( RegisteredGroups', pure RegisteredGroups )
       , ( NoGroups', pure NoGroups )
       ]
-  (res, selView) <- multiAction selOptions (classify' <$> template)
-
-  fvId <- maybe newIdent return fsId
-  MsgRenderer mr <- getMsgRenderer
-
-  return (res,
-    [ FieldView
-      { fvLabel = toHtml $ mr fsLabel
-      , fvTooltip = toHtml . mr <$> fsTooltip
-      , fvId
-      , fvInput = selView
-      , fvErrors = case res of
-          FormFailure [e] -> Just $ toHtml e
-          _ -> Nothing
-      , fvRequired = True
-      }
-    ])
-
-  where
     classify' :: SheetGroup -> SheetGroup'
     classify' = \case
       Arbitrary _ -> Arbitrary'
@@ -621,48 +602,41 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
                  , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                  }) cPairs
 
-multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+multiAction :: forall action a.
+               ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
             => Map action (AForm (HandlerT UniWorX IO) a)
+            -> FieldSettings UniWorX
             -> Maybe action
-            -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
+            -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
-multiAction acts defAction = do
+multiAction acts fs@FieldSettings{..} defAction csrf = do
   mr <- getMessageRender
+
   let
     options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
-  (actionRes, actionView) <- mreq (selectField $ return options) "" defAction
+  (actionRes, actionView) <- mreq (selectField $ return options) fs defAction
   results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
-  let mToWidget (_, []) = return Nothing
+
-      mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
+  let actionResults = view _1 <$> results
-  widgets <- mapM mToWidget results
+      actionViews = Map.foldrWithKey accViews [] results
-  let actionWidgets = Map.foldrWithKey accWidget [] widgets
+
-      accWidget _act Nothing = id
+      accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
-      accWidget act (Just w) = cons $(widgetFile "widgets/multi-action/multi-action")
+      accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
-      actionResults = Map.map fst results
+
-  return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multi-action/multi-action-collect"))
+  return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
 
 multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
-            => FieldSettings UniWorX
+             => Map action (AForm (HandlerT UniWorX IO) a)
-            -> Map action (AForm (HandlerT UniWorX IO) a)
+             -> FieldSettings UniWorX
-            -> Maybe action
+             -> Maybe action
-            -> AForm (HandlerT UniWorX IO) a
+             -> AForm Handler a
-multiActionA FieldSettings{..} acts defAction = formToAForm $ do
+multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
-  (res, selView) <- multiAction acts defAction
 
-  fvId <- maybe newIdent return fsId
+multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
-  MsgRenderer mr <- getMsgRenderer
+             => Map action (AForm (HandlerT UniWorX IO) a)
-
+             -> FieldSettings UniWorX
-  return (res,
+             -> Maybe action
-    [ FieldView
+             -> (Html -> MForm Handler (FormResult a, Widget))
-      { fvLabel = toHtml $ mr fsLabel
+multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
-      , fvTooltip = toHtml . mr <$> fsTooltip
-      , fvId
-      , fvInput = selView
-      , fvErrors = case res of
-          FormFailure [e] -> Just $ toHtml e
-          _ -> Nothing
-      , fvRequired = True
-      }
-    ])
 
 formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
 formResultModal res finalDest handler = maybeT_ $ do

src/Handler/Utils/Form/MassInput.hs

@@ -1,19 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Handler.Utils.Form.MassInput
   ( MassInput(..)
+  , defaultMiLayout
   , massInput
+  , module Handler.Utils.Form.MassInput.Liveliness
+  , massInputA
   , massInputList
-  , BoxDimension(..)
-  , IsBoxCoord(..), boxDimension
-  , Liveliness(..)
   , ListLength(..), ListPosition(..), miDeleteList
+  , EnumLiveliness(..), EnumPosition(..)
+  , MapLiveliness(..)
   ) where
 
 import Import
 import Utils.Form
 import Utils.Lens
 import Handler.Utils.Form (secretJsonField)
+import Handler.Utils.Form.MassInput.Liveliness
+import Handler.Utils.Form.MassInput.TH
 
 import Data.Aeson
 
@@ -24,35 +29,15 @@ import Text.Blaze (Markup)
 import qualified Data.Text as Text
 
 import qualified Data.Set as Set
+import qualified Data.IntSet as IntSet
+import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Foldable as Fold
-import Data.List (genericLength, genericIndex, iterate)
 
-import Control.Monad.Trans.Maybe
 import Control.Monad.Reader.Class (MonadReader(local))
 
 
-data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
+$(mapM tupleBoxCoord [2..4])
-  
-class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where
-  boxDimensions :: [BoxDimension x]
-  boxOrigin :: x
-
-boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
-boxDimension n
-  | n < genericLength dims = genericIndex dims n
-  | otherwise = error "boxDimension: insufficient dimensions"
-  where
-    dims = boxDimensions
-
--- 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
-  liveCoord :: BoxCoord a -> Prism' Bool a
-  liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
 
 
 newtype ListLength = ListLength { unListLength :: Natural }
@@ -70,13 +55,13 @@ instance BoundedJoinSemiLattice ListLength where
   bottom = 0
 
 newtype ListPosition = ListPosition { unListPosition :: Natural }
-  deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSONKey, FromJSONKey)
+  deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
   deriving (Eq, Ord, Generic, Typeable, Read, Show)
 
 makeWrapped ''ListPosition
 
 instance IsBoxCoord ListPosition where
-  boxDimensions = [BoxDimension id]
+  boxDimensions = [BoxDimension _Wrapped]
   boxOrigin = 0
 
 instance Liveliness ListLength where
@@ -94,7 +79,66 @@ instance Liveliness ListLength where
         = Nothing
         where
           max' = Set.lookupMax ns
-  liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
+  liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just bottom) (1 <$ guard (n == 0)))
+
+
+newtype EnumLiveliness enum = EnumLiveliness { unEnumLiveliness :: IntSet }
+  deriving (Eq, Ord, Generic, Typeable, Read, Show)
+
+makeWrapped ''EnumLiveliness
+
+instance JoinSemiLattice (EnumLiveliness enum) where
+  (EnumLiveliness a) \/ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.union` b
+instance MeetSemiLattice (EnumLiveliness enum) where
+  (EnumLiveliness a) /\ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.intersection` b
+instance Lattice (EnumLiveliness enum)
+instance BoundedJoinSemiLattice (EnumLiveliness enum) where
+  bottom = EnumLiveliness IntSet.empty
+instance (Enum enum, Bounded enum) => BoundedMeetSemiLattice (EnumLiveliness enum) where
+  top = EnumLiveliness . IntSet.fromList $ map (fromEnum :: enum -> Int) [minBound..maxBound]
+instance (Enum enum, Bounded enum) => BoundedLattice (EnumLiveliness enum)
+
+
+newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum }
+  deriving newtype (Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
+  deriving (Eq, Ord, Generic, Typeable, Read, Show)
+
+makeWrapped ''EnumPosition
+
+instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => IsBoxCoord (EnumPosition enum) where
+  boxDimensions = [BoxDimension _Wrapped]
+  boxOrigin = minBound
+
+instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => Liveliness (EnumLiveliness enum) where
+  type BoxCoord (EnumLiveliness enum) = EnumPosition enum
+  liveCoords = iso fromSet toSet
+    where
+      toSet = Set.fromList . map toEnum . IntSet.toList . unEnumLiveliness
+      fromSet = EnumLiveliness . IntSet.fromList . map fromEnum . Set.toList
+
+
+newtype MapLiveliness l1 l2 = MapLiveliness { unMapLiveliness :: Map (BoxCoord l1) l2 }
+  deriving (Generic, Typeable)
+
+makeWrapped ''MapLiveliness
+
+deriving instance (Ord (BoxCoord l1), JoinSemiLattice l2) => JoinSemiLattice (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), MeetSemiLattice l2) => MeetSemiLattice (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedLattice l2) => BoundedLattice (MapLiveliness l1 l2)
+deriving instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2)
+deriving instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2)
+deriving instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2)
+
+instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) where
+  type BoxCoord (MapLiveliness l1 l2) = (BoxCoord l1, BoxCoord l2)
+  liveCoords = prism'
+    (Set.fromList . concatMap (\(k, v) -> (k, ) <$> Set.toAscList (review liveCoords v)) . Map.toAscList . unMapLiveliness)
+    (\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)
+
 
 
 miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
@@ -205,7 +249,17 @@ data MassInput handler liveliness cellData cellResult = MassInput
                -> Natural
                -> liveliness
                -> Bool -- ^ Decide whether an addition-operation should be permitted
+  , miAddEmpty :: BoxCoord liveliness
+               -> Natural
+               -> liveliness
+               -> Set (BoxCoord liveliness) -- ^ Usually addition widgets are only provided for dimension 0 and all _lines_ that have at least one live coordinate. `miAddEmpty` allows specifying when to provide additional widgets
   , miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
+  , miLayout :: liveliness
+             -> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
+             -> Map (BoxCoord liveliness) Widget -- Cell Widgets
+             -> Map (BoxCoord liveliness) (FieldView UniWorX) -- Delete buttons
+             -> Map (Natural, BoxCoord liveliness) Widget -- Addition forms
+             -> Widget
   }
 
 massInput :: forall handler cellData cellResult liveliness.
@@ -243,10 +297,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
   sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
 
   let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
-      addForm = addForm' boxOrigin . zip [0..]
+      addForm = addForm' boxOrigin [] . zip [0..]
         where
-          addForm' _ [] = return Map.empty
+          addForm' _ _ [] = return Map.empty
-          addForm' miCoord ((dimIx, _) : remDims) = do
+          addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
             let nudgeAddWidgetName :: Text -> Text
                 nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
             (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
@@ -262,9 +316,12 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
             case remDims of
               [] -> return dimRes'
               ((_, BoxDimension dim) : _) -> do
-                let
+                let miCoords
-                  miCoords = Set.fromList . takeWhile (\c -> review (liveCoord c) sentLiveliness) $ iterate (over dim succ) miCoord
+                      = Set.union (miAddEmpty miCoord dimIx sentLiveliness)
-                dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords
+                      . Set.map (\c -> miCoord & dim .~ (c ^. dim))
+                      . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
+                      $ review liveCoords sentLiveliness
+                dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
                 return $ dimRes' `Map.union` fold dimRess
 
   addResults <- addForm boxDimensions
@@ -342,22 +399,13 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
         guard $ not shapeChanged
         for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult
 
-  let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
+  let miWidget
-      miWidget' _ [] = mempty
+        = miLayout
-      miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) =
+          liveliness
-        let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord
+          (fmap (view _1 &&& view (_2 . _1)) cellResults)
-            cells
+          (fmap (view $ _2 . _2) cellResults)
-              | [] <- remDims = do
+          (fmap (view _2) delResults)
-                  coord <- coords
+          (Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults)
-                  Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults 
-                  let deleteButton = snd <$> Map.lookup coord delResults
-                  return (coord, $(widgetFile "widgets/massinput/cell"))
-              | otherwise =
-                  [ (coord, miWidget' coord remDims) | coord <- coords ]
-            addWidget = (\(_, mWgt) -> mWgt <* guard (miAllowAdd miCoord dimIx liveliness)) =<< Map.lookup (dimIx, miCoord) addResults
-         in $(widgetFile "widgets/massinput/row")
-
-      miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions
 
   MsgRenderer mr <- getMsgRenderer
 
@@ -368,6 +416,32 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
     fvErrors = Nothing
     in return (result, FieldView{..})
 
+defaultMiLayout :: forall liveliness cellData cellResult.
+                   Liveliness liveliness
+                => liveliness
+                -> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
+                -> Map (BoxCoord liveliness) Widget
+                -> Map (BoxCoord liveliness) (FieldView UniWorX)
+                -> Map (Natural, BoxCoord liveliness) Widget
+                -> Widget
+-- | Generic `miLayout` using recursively nested lists
+defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOrigin [] $ zip [0..] boxDimensions
+  where
+    miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
+    miWidget' _ _ [] = mempty
+    miWidget' miCoord pDims (dim'@(dimIx, BoxDimension dim) : remDims) =
+      let coords = Set.toList . Set.map (\c -> miCoord & dim .~ (c ^. dim)) . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims ]) $ review liveCoords liveliness
+          cells
+            | [] <- remDims = do
+                coord <- coords
+                Just cellWdgt <- return $ Map.lookup coord cellResults 
+                let deleteButton = Map.lookup coord delResults
+                return (coord, $(widgetFile "widgets/massinput/cell"))
+            | otherwise =
+                [ (coord, miWidget' coord (pDims `snoc` dim') remDims) | coord <- coords ]
+          addWidget = Map.lookup (dimIx, miCoord) addResults
+       in $(widgetFile "widgets/massinput/row")
+
 
 -- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
 massInputList :: forall handler cellResult.
@@ -388,8 +462,25 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes
                 over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes
             , miDelete = miDeleteList
             , miAllowAdd = \_ _ _ -> True
+            , miAddEmpty = \_ _ _ -> Set.empty
             , miButtonAction
+            , miLayout = \lLength _ cellWdgts delButtons addWdgts
+              -> $(widgetFile "widgets/massinput/list/layout")
             }
   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/Handler/Utils/Form/MassInput/Liveliness.hs

@@ -0,0 +1,45 @@
+module Handler.Utils.Form.MassInput.Liveliness
+  ( BoxDimension(..)
+  , IsBoxCoord(..)
+  , boxDimension
+  , Liveliness(..)
+  ) where
+
+import ClassyPrelude
+
+import Web.PathPieces (PathPiece)
+import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey)
+
+import Numeric.Natural
+
+import Utils.Lens
+
+import Algebra.Lattice
+
+import qualified Data.Set as Set
+import Data.List (genericLength, genericIndex)
+
+
+data BoxDimension x = forall n. (Enum n, Eq n) => BoxDimension (Lens' x n)
+
+class (ToJSON x, FromJSON x, ToJSONKey x, FromJSONKey x, PathPiece x, Eq x, Ord x) => IsBoxCoord x where
+  boxDimensions :: [BoxDimension x]
+  boxOrigin :: x
+
+boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
+boxDimension n
+  | n < genericLength dims = genericIndex dims n
+  | otherwise = error "boxDimension: insufficient dimensions"
+  where
+    dims = boxDimensions
+
+-- 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
+  liveCoord :: BoxCoord a -> Prism' Bool a
+  liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
+
+

src/Handler/Utils/Form/MassInput/TH.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Handler.Utils.Form.MassInput.TH
+  ( tupleBoxCoord
+  ) where
+
+import Prelude
+import Handler.Utils.Form.MassInput.Liveliness
+
+import Language.Haskell.TH
+
+import Control.Lens
+
+import Data.List ((!!))
+
+
+tupleBoxCoord :: Int -> DecQ
+tupleBoxCoord tupleDim = do
+  cs <- sequence . replicate tupleDim $ newName "c"
+
+  let tupleType = foldl appT (tupleT tupleDim) $ map varT cs
+      tCxt = cxt $ concat
+        [ [ [t|IsBoxCoord $(varT c)|] | c <- cs ]
+        ]
+      fieldLenses =
+        [ [e|_1|]
+        , [e|_2|]
+        , [e|_3|]
+        , [e|_4|]
+        ]
+
+  instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType)
+    [ funD 'boxDimensions
+      [ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) . map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(field) . dim) boxDimensions|]) $ map (fieldLenses !!) [0..pred tupleDim]) []
+      ]
+    , funD 'boxOrigin
+      [ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) []
+      ]
+    ]

src/Handler/Utils/Mail.hs

@@ -1,12 +1,13 @@
 module Handler.Utils.Mail
   ( addRecipientsDB
+  , userAddress
   , userMailT
   , addFileDB
   ) where
 
 import Import
 
-import Utils.Lens hiding (snoc)
+import Utils.Lens
 
 import qualified Data.CaseInsensitive as CI
 
@@ -31,22 +32,22 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectS
       let addr = Address (Just userDisplayName) $ CI.original userEmail
       _mailTo %= flip snoc addr
 
+userAddress :: User -> Address
+userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail
+
 userMailT :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
              , MonadBaseControl IO m
              , MonadLogger m
              ) => UserId -> MailT m a -> m a
 userMailT uid mAct = do
-  User
+  user@User
-    { userEmail
+    { userMailLanguages
-    , userDisplayName
-    , userMailLanguages
     , userDateTimeFormat
     , userDateFormat
     , userTimeFormat
     } <- liftHandlerT . runDB $ getJust uid
   let
-    addr = Address (Just userDisplayName) $ CI.original userEmail
     ctx = MailContext
       { mcLanguages = userMailLanguages
       , mcDateTimeFormat = \case
@@ -55,7 +56,7 @@ userMailT uid mAct = do
           SelFormatTime -> userTimeFormat
       }
   mailT ctx $ do
-    _mailTo .= pure addr
+    _mailTo .= pure (userAddress user)
     mAct
 
 addFileDB :: ( MonadMail m
@@ -69,4 +70,4 @@ addFileDB fId = do
     _partEncoding .= Base64
     _partFilename .= Just fileName
     _partContent .= LBS.fromStrict fileContent
-    setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId
+    setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId

src/Handler/Utils/Rating.hs

@@ -18,8 +18,6 @@ import Import
 
 import Text.PrettyPrint.Leijen.Text hiding ((<$>))
 
-import Control.Monad.Trans.Maybe
-
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import Data.Text.Encoding.Error (UnicodeException(..))

src/Import/NoFoundation.hs

@@ -3,7 +3,7 @@ module Import.NoFoundation
     , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
@@ -36,6 +36,7 @@ import Text.Lucius            as Import
 import Text.Shakespeare.Text  as Import hiding (text, stext)
 
 import Data.Universe          as Import
+import Data.Universe.TH       as Import
 import Data.Pool              as Import (Pool)
 import Network.HaskellNet.SMTP as Import (SMTPConnection)
 
@@ -54,6 +55,7 @@ import Data.Text.Encoding.Error as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Semigroup)
 import Data.Monoid            as Import (Last(..), First(..))
 import Data.Monoid.Instances  as Import ()
+import Data.Set.Instances     as Import ()
 import Data.HashMap.Strict.Instances as Import ()
 import Data.HashSet.Instances as Import ()
 import Data.Vector.Instances  as Import ()
@@ -80,7 +82,9 @@ import Numeric.Natural.Instances as Import ()
 import System.Random as Import (Random)
 import Control.Monad.Random.Class as Import (MonadRandom(..))
 
+import Text.Blaze.Instances as Import ()
 import Jose.Jwt.Instances as Import ()
+import Web.PathPieces.Instances as Import ()
 
 
 import Control.Monad.Trans.RWS (RWST)

src/Jobs.hs

@@ -59,6 +59,7 @@ import Jobs.Handler.QueueNotification
 import Jobs.Handler.HelpRequest
 import Jobs.Handler.SetLogSettings
 import Jobs.Handler.DistributeCorrections
+import Jobs.Handler.SendCourseCommunication
 import Jobs.Handler.LecturerInvitation
 
   

src/Jobs/Handler/HelpRequest.hs

@@ -23,13 +23,13 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId
 dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
   supportAddress <- view _appMailSupport
   userInfo <- bitraverse return (runDB . getEntity) jSender
-  let userAddress = either
+  let senderAddress = either
         id
         (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
         userInfo
   mailT def $ do
     _mailTo .= [supportAddress]
-    whenIsJust userAddress (_mailFrom .=)
+    whenIsJust senderAddress (_mailFrom .=)
     replaceMailHeader "Auto-Submitted" $ Just "no"
     setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject
     setDate jRequestTime

src/Jobs/Handler/LecturerInvitation.hs

@@ -12,8 +12,6 @@ import qualified Data.CaseInsensitive as CI
 
 import Utils.Lens
 
-import Control.Monad.Trans.Maybe
-
 
 dispatchJobLecturerInvitation :: UserId -> LecturerInvitation -> Handler ()
 dispatchJobLecturerInvitation jInviter jLecturerInvitation@LecturerInvitation{..} = do

src/Jobs/Handler/SendCourseCommunication.hs

@@ -0,0 +1,37 @@
+module Jobs.Handler.SendCourseCommunication
+  ( dispatchJobSendCourseCommunication
+  ) where
+
+import Import
+
+import Utils.Lens
+import Handler.Utils
+
+import qualified Data.Set as Set
+
+import qualified Data.CaseInsensitive as CI
+
+
+dispatchJobSendCourseCommunication :: Either UserEmail UserId
+                                   -> Set Address
+                                   -> CourseId
+                                   -> UserId
+                                   -> UUID
+                                   -> Maybe Text
+                                   -> Html
+                                   -> Handler ()
+dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID jSubject jMailContent = do
+  (sender, Course{..}) <- runDB $ (,)
+    <$> getJust jSender
+    <*> getJust jCourse
+  either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
+    void $ setMailObjectUUID jMailObjectUUID
+    _mailFrom .= userAddress sender
+    if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients
+      | jRecipientEmail == Right jSender
+      -> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses)
+      | otherwise
+      -> addMailHeader "Cc" "Undisclosed Recipients:;"
+    addMailHeader "Auto-Submitted" "no"
+    setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject
+    void $ addPart jMailContent

src/Jobs/Queue.hs

@@ -2,7 +2,7 @@ module Jobs.Queue
   ( writeJobCtl, writeJobCtlBlock
   , queueJob, queueJob'
   , YesodJobDB
-  , runDBJobs, queueDBJob
+  , runDBJobs, queueDBJob, sinkDBJobs
   , module Jobs.Types
   ) where
 
@@ -21,6 +21,8 @@ import qualified Data.HashMap.Strict as HashMap
 
 import Control.Monad.Random (evalRand, mkStdGen, uniform)
 
+import qualified Data.Conduit.List as C
+
 
 data JobQueueException = JobQueuePoolEmpty
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
@@ -29,6 +31,10 @@ instance Exception JobQueueException
 
 
 writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
+-- | Pass an instruction to the `Job`-Workers
+--
+-- Instructions are assigned deterministically and pseudo-randomly to one specific worker.
+-- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others
 writeJobCtl cmd = do
   tid <- liftIO myThreadId
   wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO
@@ -39,6 +45,7 @@ writeJobCtl cmd = do
         liftIO . atomically $ writeTMChan chan cmd
 
 writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
+-- | Pass an instruction to the `Job`-Workers and block until it was acted upon
 writeJobCtlBlock cmd = do
   getResVar <- asks jobConfirm
   resVar <- liftIO . atomically $ do
@@ -67,19 +74,30 @@ queueJobUnsafe job = do
   -- return jId
 
 queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
+-- ^ Queue a job for later execution
+--
+-- Makes no guarantees as to when it will be executed (`queueJob'`) and does not interact with any running database transactions (`runDBJobs`)
 queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
 
 queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
--- ^ `queueJob` followed by `JobCtlPerform`
+-- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap
 queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
 
+-- | Slightly modified Version of `YesodDB` for `runDBJobs`
 type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
 
-queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
+queueDBJob :: Job -> YesodJobDB UniWorX ()
+-- | Queue a job as part of a database transaction and execute it after the transaction succeeds
 queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
 
-runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX)
+sinkDBJobs :: Sink Job (YesodJobDB UniWorX) ()
- => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
+-- | Queue many jobs as part of a database transaction and execute them after the transaction passes
+sinkDBJobs = C.mapM_ queueDBJob
+
+runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a
+-- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction
+--
+-- Jobs get immediately executed if the transaction succeeds
 runDBJobs act = do
   (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
   forM_ jIds $ writeJobCtl . JobCtlPerform

src/Jobs/Types.hs

@@ -15,14 +15,22 @@ import Data.List.NonEmpty (NonEmpty)
 data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
          | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
          | JobQueueNotification { jNotification :: Notification }
-         | JobHelpRequest { jSender :: Either (Maybe Address) UserId
+         | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
                           , jRequestTime :: UTCTime
-                          , jHelpSubject :: Maybe Text
+                          , jSubject :: Maybe Text
                           , jHelpRequest :: Text
                           , jReferer :: Maybe Text
                           }
          | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
          | JobDistributeCorrections { jSheet :: SheetId }
+         | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId
+                                      , jAllRecipientAddresses :: Set Address
+                                      , jCourse :: CourseId
+                                      , jSender :: UserId
+                                      , jMailObjectUUID :: UUID
+                                      , jSubject :: Maybe Text
+                                      , jMailContent :: Html
+                                      }
          | JobLecturerInvitation { jInviter :: UserId
                                  , jLecturerInvitation :: LecturerInvitation
                                  }
@@ -40,15 +48,15 @@ instance Hashable Job
 instance Hashable Notification
 
 deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  { constructorTagModifier = camelToPathPiece' 1
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = camelToPathPiece' 1
   , tagSingleConstructors = True
   , sumEncoding = TaggedObject "job" "data"
   } ''Job
 
 deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  { constructorTagModifier = camelToPathPiece' 1
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = camelToPathPiece' 1
   , tagSingleConstructors = True
   , sumEncoding = TaggedObject "notification" "data"
   } ''Notification

src/Mail.hs

@@ -7,7 +7,9 @@ module Mail
     module Network.Mail.Mime
     -- * MailT
   , MailT, defMailT
-  , MailSmtpData(..), MailContext(..), MailLanguages(..)
+  , MailSmtpData(..)
+  , _MailSmtpDataSet
+  , MailContext(..), MailLanguages(..)
   , MonadMail(..)
   , getMailMessageRender, getMailMsgRenderer
     -- * YesodMail
@@ -24,7 +26,8 @@ module Mail
   , MailObjectId
   , replaceMailHeader, addMailHeader, removeMailHeader
   , replaceMailHeaderI, addMailHeaderI
-  , setSubjectI, setMailObjectId, setMailObjectId'
+  , setSubjectI
+  , setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
   , setDate, setDateCurrent
   , setMailSmtpData
   , _addressName, _addressEmail
@@ -61,18 +64,19 @@ import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Builder as LTB
 import qualified Data.ByteString.Lazy as LBS
 
-import Utils (MsgRendererS(..))
+import Utils (MsgRendererS(..), MonadSecretBox(..))
 import Utils.Lens.TH
 import Control.Lens hiding (from)
+import Control.Lens.Extras (is)
 
 import Text.Blaze.Renderer.Utf8
 
 import Data.UUID (UUID)
 import qualified Data.UUID as UUID
-import qualified Data.UUID.V4 as UUID
 import Data.UUID.Cryptographic.ImplicitNamespace
 
 import Data.Binary (Binary)
+import qualified Data.Binary as Binary
 
 import GHC.TypeLits (KnownSymbol)
 
@@ -105,6 +109,12 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
   
+import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen)
+import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..))
+import qualified Data.ByteArray as ByteArray (convert)
+import Crypto.MAC.HMAC (hmac, HMAC)
+import Crypto.Hash.Algorithms (SHAKE128)
+
 
 makeLenses_ ''Address
 makeLenses_ ''Mail
@@ -133,6 +143,13 @@ instance Monoid (MailSmtpData) where
   mempty = memptydefault
   mappend = mappenddefault
 
+_MailSmtpDataSet :: Getter MailSmtpData Bool
+_MailSmtpDataSet = to $ \MailSmtpData{..} -> none id
+  [ is (_Wrapped . _Nothing) smtpEnvelopeFrom
+  , Set.null smtpRecipients
+  ]
+
+
 newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
   deriving newtype (FromJSON, ToJSON, IsList)
@@ -426,20 +443,33 @@ setMailObjectUUID uuid = do
   replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
   return objectId
 
-setMailObjectId :: ( MonadHeader m
+setMailObjectIdRandom :: ( MonadHeader m
-                   , YesodMail (HandlerSite m)
+                         , YesodMail (HandlerSite m)
-                   ) => m MailObjectId
+                         ) => m MailObjectId
-setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
+setMailObjectIdRandom = setMailObjectUUID =<< liftIO getRandom
 
-setMailObjectId' :: ( MonadHeader m
+setMailObjectIdCrypto :: ( MonadHeader m
-                    , YesodMail (HandlerSite m)
+                         , YesodMail (HandlerSite m)
-                    , MonadCrypto m
+                         , MonadCrypto m
-                    , HasCryptoUUID plain m
+                         , HasCryptoUUID plain m
-                    , MonadCryptoKey m ~ CryptoIDKey
+                         , MonadCryptoKey m ~ CryptoIDKey
-                    , KnownSymbol (CryptoIDNamespace UUID plain)
+                         , KnownSymbol (CryptoIDNamespace UUID plain)
-                    , Binary plain
+                         , Binary plain
-                    ) => plain -> m MailObjectId
+                         ) => plain -> m MailObjectId
-setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
+setMailObjectIdCrypto oid = setMailObjectUUID . ciphertext =<< encrypt oid
+
+setMailObjectIdPseudorandom :: ( MonadHeader m
+                               , YesodMail (HandlerSite m)
+                               , Binary obj
+                               , MonadSecretBox m
+                               ) => obj -> m MailObjectId
+-- | Designed to leak no information about the `secretBoxKey` or the given object
+setMailObjectIdPseudorandom obj = do
+  sbKey <- secretBoxKey
+  let
+    seed :: HMAC (SHAKE128 64)
+    seed = hmac (Saltine.encode sbKey) . toStrict $ Binary.encode obj
+  setMailObjectUUID . evalRand getRandom . mkStdGen $ hash (ByteArray.convert seed :: ByteString)
 
 
 setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()

src/Text/Blaze/Instances.hs

@@ -0,0 +1,37 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Text.Blaze.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Text.Blaze
+import qualified Text.Blaze.Renderer.Text as Text
+
+import Text.Read (Read(..))
+
+import Data.Hashable (Hashable(..))
+import Data.Aeson (ToJSON(..), FromJSON(..))
+import qualified Data.Aeson as Aeson
+
+
+instance Eq Markup where
+  (==) = (==) `on` Text.renderMarkup
+
+instance Ord Markup where
+  compare = comparing Text.renderMarkup
+
+instance Read Markup where
+  readPrec = preEscapedLazyText <$> readPrec
+
+instance Show Markup where
+  showsPrec prec = showsPrec prec . Text.renderMarkup
+
+instance Hashable Markup where
+  hashWithSalt s = hashWithSalt s . Text.renderMarkup
+
+instance ToJSON Markup where
+  toJSON = Aeson.String . toStrict . Text.renderMarkup
+
+instance FromJSON Markup where
+  parseJSON = Aeson.withText "Html" $ return . preEscapedText

src/Utils.hs

@@ -45,7 +45,7 @@ import Control.Lens as Utils (none)
 import Control.Arrow as Utils ((>>>))
 import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
 import Control.Monad.Except (MonadError(..))
-import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
 import Control.Monad.Catch hiding (throwM)
 
 

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/Lens.hs

@@ -2,7 +2,7 @@ module Utils.Lens ( module Utils.Lens ) where
 
 import ClassyPrelude.Yesod hiding ((.=))
 import Model
-import Control.Lens as Utils.Lens hiding ((<.>))
+import Control.Lens as Utils.Lens hiding ((<.>), universe, snoc)
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
 
@@ -94,6 +94,8 @@ makeLenses_ ''StudyTerms
 
 makeLenses_ ''StudyTermCandidate
 
+makeLenses_ ''FieldView
+
 makePrisms ''HandlerContents
 
 makePrisms ''ErrorResponse

src/Utils/Parameters.hs

@@ -1,10 +1,10 @@
 module Utils.Parameters
   ( GlobalGetParam(..)
-  , lookupGlobalGetParam, hasGlobalGetParam
+  , lookupGlobalGetParam, hasGlobalGetParam, lookupGlobalGetParams
   , lookupGlobalGetParamForm, hasGlobalGetParamForm
   , globalGetParamField
   , GlobalPostParam(..)
-  , lookupGlobalPostParam, hasGlobalPostParam
+  , lookupGlobalPostParam, hasGlobalPostParam, lookupGlobalPostParams
   , lookupGlobalPostParamForm, hasGlobalPostParamForm
   , globalPostParamField
   ) where
@@ -20,7 +20,7 @@ import Data.Universe
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
-data GlobalGetParam = GetReferer | GetBearer
+data GlobalGetParam = GetReferer | GetBearer | GetRecipient
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalGetParam
@@ -33,6 +33,9 @@ lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece
 hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
 hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
 
+lookupGlobalGetParams :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m [result]
+lookupGlobalGetParams ident = mapMaybe fromPathPiece <$> lookupGetParams (toPathPiece ident)
+
 
 lookupGlobalGetParamForm :: (Monad m, PathPiece result) => GlobalGetParam -> MForm m (Maybe result)
 lookupGlobalGetParamForm ident = runMaybeT $ do
@@ -42,7 +45,7 @@ lookupGlobalGetParamForm ident = runMaybeT $ do
 hasGlobalGetParamForm :: Monad m => GlobalGetParam -> MForm m Bool
 hasGlobalGetParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
 
-globalGetParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a)
+globalGetParamField :: Monad m => GlobalGetParam -> Field m a -> MForm m (Maybe a)
 globalGetParamField ident Field{fieldParse} = runMaybeT $ do
   ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
   fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
@@ -64,6 +67,10 @@ lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPie
 hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
 hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
   
+lookupGlobalPostParams :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m [result]
+lookupGlobalPostParams ident = mapMaybe fromPathPiece <$> lookupPostParams (toPathPiece ident)
+
+  
 lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result)
 lookupGlobalPostParamForm ident = runMaybeT $ do
   ps <- MaybeT askParams

src/Utils/PathPiece.hs

@@ -4,6 +4,7 @@ module Utils.PathPiece
   , nullaryPathPiece
   , splitCamel
   , camelToPathPiece, camelToPathPiece'
+  , tuplePathPiece
   ) where
 
 import ClassyPrelude.Yesod
@@ -17,6 +18,9 @@ import qualified Data.Char as Char
 
 import Numeric.Natural
 
+import Data.List (foldl)
+  
+
 finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
 finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
   [x] -> Just x
@@ -63,3 +67,32 @@ camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dro
 
 camelToPathPiece :: Textual t => t -> t
 camelToPathPiece = camelToPathPiece' 0
+
+
+tuplePathPiece :: Int -> DecQ
+tuplePathPiece tupleDim = do
+  let
+    tupleSeparator :: Text
+    tupleSeparator = ","
+  
+  xs <- sequence . replicate tupleDim $ newName "x" :: Q [Name]
+  xs' <- sequence . replicate tupleDim $ newName "x'" :: Q [Name]
+
+  let tupleType = foldl appT (tupleT tupleDim) $ map varT xs
+      tCxt = cxt
+        [ [t|PathPiece $(varT x)|] | x <- xs ]
+
+  t <- newName "t"
+
+  instanceD tCxt [t|PathPiece $(tupleType)|]
+    [ funD 'toPathPiece
+      [ clause [tupP $ map varP xs] (normalB [e|Text.intercalate tupleSeparator $(listE $ map (appE [e|toPathPiece|] . varE) xs)|]) []
+      ]
+    , funD 'fromPathPiece
+      [ clause [varP t] (normalB . doE $ concat
+                         [ pure $ bindS (listP $ map varP xs) [e|return $ Text.splitOn tupleSeparator $(varE t)|]
+                         , [ bindS (varP x') [e|fromPathPiece $(varE x)|] | (x, x') <- zip xs xs' ]
+                         , pure $ noBindS [e|return $(tupE $ map varE xs')|]
+                         ]) []
+      ]
+    ]

src/Web/PathPieces/Instances.hs

@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Web.PathPieces.Instances
+  (
+  ) where
+
+import Prelude
+
+import Utils.PathPiece
+
+
+$(mapM tuplePathPiece [2..4])

src/Yesod/Core/Instances.hs

@@ -102,4 +102,4 @@ instance Extend FormResult where
   duplicated  FormMissing       = FormMissing
   duplicated (FormFailure errs) = FormFailure errs
 
-
+deriving instance Eq a => Eq (FormResult a)

static/css/utils/form.scss

@@ -1,16 +1,13 @@
 fieldset {
   border: 0;
-  margin: 20px 0 30px;
+  margin: 0;
+  padding: 0;
 
   legend {
     display: none;
   }
 }
 
-.form-group__input > fieldset {
-  margin-bottom: 0;
-}
-
 @media (min-width: 769px) {
   .form-group__input {
     grid-column: 2;

static/js/utils/form.js

@@ -124,8 +124,10 @@
    *    Selector for the input that this fieldset watches for changes
    *  data-conditional-value: string
    *    The value the conditional input needs to be set to for this fieldset to be shown
+   *    Can be omitted if conditionalInput is a checkbox
    *
    * Example usage:
+   * ## example with text input
    *  <input id="input-0" type="text">
    *  <fieldset uw-interactive-fieldset data-conditional-input="#input-0" data-conditional-value="yes">...</fieldset>
    *  <fieldset uw-interactive-fieldset data-conditional-input="#input-0" data-conditional-value="no">...</fieldset>
@@ -135,16 +137,25 @@
    *    <option value="1">One
    *  <fieldset uw-interactive-fieldset data-conditional-input="#select-0" data-conditional-value="0">...</fieldset>
    *  <fieldset uw-interactive-fieldset data-conditional-input="#select-0" data-conditional-value="1">...</fieldset>
+   * ## example with checkbox
+   *  <input id="checkbox-0" type="checkbox">
+   *  <input id="checkbox-1" type="checkbox">
+   *  <fieldset uw-interactive-fieldset data-conditional-input="#checkbox-0">...</fieldset>
+   *  <fieldset uw-interactive-fieldset data-conditional-input="#checkbox-1">...</fieldset>
    */
 
   var INTERACTIVE_FIELDSET_UTIL_NAME = 'interactiveFieldset';
   var INTERACTIVE_FIELDSET_UTIL_SELECTOR = '[uw-interactive-fieldset]';
+  var INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR = '.interactive-fieldset--target';
 
   var INTERACTIVE_FIELDSET_INITIALIZED_CLASS = 'interactive-fieldset--initialized';
+  var INTERACTIVE_FIELDSET_CHILD_SELECTOR = 'input:not([disabled])';
 
   var interactiveFieldsetUtil = function(element) {
     var conditionalInput;
     var conditionalValue;
+    var target;
+    var childInputs;
 
     function init() {
       if (!element) {
@@ -166,11 +177,23 @@
       }
 
       // param conditionalValue
-      if (!element.dataset.conditionalValue) {
+      if (!element.dataset.conditionalValue && !isCheckbox()) {
         throw new Error('Interactive Fieldset needs a conditional value!');
       }
       conditionalValue = element.dataset.conditionalValue;
 
+      if (element.matches(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR)) {
+        target = element;
+      }
+      if (!target) {
+        target = element.closest(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR);
+      }
+      if (!target) {
+        throw new Error('Interactive Fieldset needs to be a target or have a target-ancestor!');
+      }
+
+      childInputs = Array.from(element.querySelectorAll(INTERACTIVE_FIELDSET_CHILD_SELECTOR));
+
       // add event listener
       conditionalInput.addEventListener('input', updateVisibility);
 
@@ -188,7 +211,25 @@
     }
 
     function updateVisibility() {
-      element.classList.toggle('hidden', conditionalInput.value !== conditionalValue);
+      var active = matchesConditionalValue();
+      
+      target.classList.toggle('hidden', !active);
+
+      childInputs.forEach(function(el) {
+        el.toggleAttribute('disabled', !active);
+      });
+    }
+
+    function matchesConditionalValue() {
+      if (isCheckbox()) {
+        return conditionalInput.checked === true;
+      }
+
+      return conditionalInput.value === conditionalValue;
+    }
+
+    function isCheckbox() {
+      return conditionalInput.getAttribute('type') === 'checkbox';
     }
 
     return init();
@@ -260,6 +301,7 @@
   var FORM_GROUP_SELECTOR = '.form-group';
   var FORM_GROUP_WITH_ERRORS_CLASS = 'form-group--has-error';
 
+
   var formErrorRemoverUtil = function(element) {
     var formGroups;
 

templates/course/lecturerMassInput/add.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td colspan=3>
+  #{csrf}
+  ^{fvInput addView}
+<td>
+  ^{fvInput btn}

templates/course/lecturerMassInput/cellInvitation.hamlet

@@ -0,0 +1,12 @@
+ $newline never
+ <td>
+   #{csrf}
+   <span style="font-family: monospace">
+     #{lEmail}
+ <td>
+   <div .tooltip>
+     <div .tooltip__handle>
+     <div .tooltip__content>
+       _{MsgEmailInvitationWarning}
+ <td>
+   ^{fvInput lrwView}

templates/course/lecturerMassInput/cellKnown.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td colspan=2>
+  #{csrf}
+  ^{nameEmailWidget userEmail userDisplayName userSurname} #
+<td>
+  ^{fvInput lrwView}

templates/course/lecturerMassInput/layout.hamlet

@@ -0,0 +1,11 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput--cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/aform/aform.hamlet

@@ -11,7 +11,7 @@ $case formLayout
         <h3 .form-section-title>
           ^{fvLabel view}
       $else
-        <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
+        <div .form-group .interactive-fieldset--target :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
           $if not (Blaze.null $ fvLabel view)
             <label .form-group-label for=#{fvId view}>
               <span .form-group-label__caption>

templates/widgets/communication/recipientAdd.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<div .category__entry-add>
+  #{csrf}
+  ^{fvInput addView}
+  ^{fvInput submitView}

templates/widgets/communication/recipientEmail.hamlet

@@ -0,0 +1,7 @@
+$newline never
+<div .category__option>
+  #{csrf}
+  ^{fvInput tickView}
+  <label for=#{fvId tickView}>
+    <span style="font-family: monospace">
+      #{email}

templates/widgets/communication/recipientLayout.hamlet

@@ -0,0 +1,13 @@
+$newline never
+$forall category <- activeCategories
+  <div .category>
+    <input type=checkbox id=#{checkedIdent category} :elem category checkedCategories:checked>
+    <label for=#{checkedIdent category}>
+      _{category}
+
+    <fieldset uw-interactive-fieldset data-conditional-input=#{checkedIdent category} .interactive-fieldset--target>
+      $forall optIx <- categoryIndices category
+        ^{cellWdgts ! optIx}
+
+      $maybe addWdgt <- addWdgts !? (1, (EnumPosition category, 0))
+        ^{addWdgt}

templates/widgets/communication/recipientName.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<div .category__option>
+  #{csrf}
+  ^{fvInput tickView}
+  <label for=#{fvId tickView}>
+    #{nameHtml userDisplayName userSurname}

templates/widgets/massinput/list/layout.hamlet

@@ -0,0 +1,14 @@
+$newline never
+<table>
+  <tbody>
+    <tr .massinput--cell>
+      $forall coord <- review liveCoords lLength
+        <td>
+          ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr>
+      <td>
+      <td .massinput--add>
+        ^{addWdgts ! (0, 0)}

templates/widgets/multi-action/multi-action-collect.hamlet

@@ -1,4 +0,0 @@
-^{fvInput actionView}
-
-$forall w <- actionWidgets
-  ^{w}