Cleanup

messages/uniworx/de.msg

@@ -736,3 +736,7 @@ CommRecipients: Empfänger
 
 AddRecipientGroups: Empfängergruppen
 AddRecipientCustom: Weitere Empfänger
+
+RGCourseParticipants: Kursteilnehmer
+RGCourseLecturers: Kursverwalter
+RGCourseCorrectors: Korrektoren

routes

@@ -78,7 +78,7 @@
   /users                      CUsersR         GET POST
   /users/#CryptoUUIDUser      CUserR          GET POST        !lecturerANDparticipant
   /correctors                 CHiWisR         GET
-  /mail                       CCommR          GET POST
+  /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/Handler/Utils/Communication.hs

@@ -1,9 +1,18 @@
 module Handler.Utils.Communication where
 
 import Import
+import Handler.Utils.Form
+import Handler.Utils.Form.MassInput
+import Utils.Lens
+
+import Jobs.Types
 
 import qualified Database.Esqueleto as E
 
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+  
+
 data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
@@ -13,17 +22,19 @@ nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1
 embedRenderMessage ''UniWorX ''RecipientGroup id
 
 
-data RecipientAddOptions
+data RecipientAddOption
   = AddRecipientGroups
   | AddRecipientGroup RecipientGroup
   | AddRecipientCustom
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
-instance Universe RecipientAddOptions where
+instance Universe RecipientAddOption where
-  universe = AddRecipientGroups:
+  universe = concat
-             [AddRecipientGroup g | g <- universe]
+    [ pure AddRecipientGroups
-             ++ [AddRecipientCustom]
+    , [ AddRecipientGroup g | g <- universe ]
-instance Finite RecipientAddOptions
+    , pure AddRecipientCustom
+    ]
+instance Finite RecipientAddOption
 
 instance PathPiece RecipientAddOption where
   toPathPiece AddRecipientGroups    = "recipient-groups"
@@ -37,19 +48,17 @@ instance RenderMessage UniWorX RecipientAddOption where
     AddRecipientGroups  -> renderMessage' MsgAddRecipientGroups
     AddRecipientCustom  -> renderMessage' MsgAddRecipientCustom
     AddRecipientGroup g -> renderMessage' g
-    where renderMessage' = renderMessage foundation ls
+    where
+      renderMessage' :: forall msg. RenderMessage UniWorX msg => msg -> Text
+      renderMessage' = renderMessage foundation ls
 
 
-data CommunicationRoute = CommuncationRoute
+data CommunicationRoute = CommunicationRoute
   { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
-  , crJob        :: MailT Handler () -> Handler Job
+  , crJob        :: Communication -> DB Job
   }
 
-data Communication = Communication
+-- `Communication` is defined in `Jobs.Types`
- { cRecipients :: Set (Either Email UserId)
- , cSubject :: Text
- }
-
 
 
 commR :: CommunicationRoute -> Handler Html
@@ -57,32 +66,40 @@ commR CommunicationRoute{..} =  do
   MsgRenderer mr <- getMsgRenderer
 
   suggestedRecipients' <- runDB $ traverse E.select crRecipients
-  suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> encrypt rid <*> pure ent
+  suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> (encrypt rid :: Handler CryptoUUIDUser) <*> pure ent
 
-  let recipientAForm :: AForm (Set (Either Email UserId))
+  let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
-      recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True Nothing
+      recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True (Nothing {- TODO -})
-        where miAdd _ _ nudge submitButton = Just $ \csrf -> do
+        where
-                let addOptions = Map.fromList . concat $
+          miAdd _ _ nudge submitView = Just $ \csrf -> do
-                      [ pure (AddRecipientGroups, apreq (selectField . return $ mkOptionsList
+            let addOptions :: Map RecipientAddOption (AForm Handler (Set (Either UserEmail UserId)))
-                              [ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ]
+                addOptions = Map.fromList . concat $
-                          ) )
+                  [ pure ( AddRecipientGroups
-                      , do
+                         , Set.unions <$> apreq (multiSelectField . return $ mkOptionList
-                          (g,recs) <- Map.toList suggestedRecipients
+                                                   [ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ]
-                          return ( AddRecipientGroup g
+                                                ) ("" & addName (nudge . toPathPiece $ AddRecipientGroups)) Nothing
-                                 , apreq (selectField . return $ mkOptionsList
+                         )
-                                     [ Option userDisplayName (Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ]
+                  , do
-                                 )
+                      (g,recs) <- Map.toList suggestedRecipients
-                      -- , pure (AddRecipientCustom, _ )
+                      return ( AddRecipientGroup g
-                      ]
+                             , Set.unions <$> apreq (multiSelectField . return $ mkOptionList
-
+                                                       [ Option userDisplayName (Set.singleton $ Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ]
-
+                                                    ) ("" & addName (nudge . toPathPiece $ AddRecipientGroup g)) Nothing
-                multiAction ()
+                             )
-              miCell
+                  -- , pure (AddRecipientCustom, _ )
-              miDelete
+                  ]
-              miAllowAdd
+            (addRes, addWdgt) <- multiActionM addOptions ("" & addName (nudge "select")) Nothing csrf
-              miButtonAction
+            error "miAdd" :: MForm Handler (FormResult (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))), Widget)
+          miCell = error "miCell"
+          miDelete :: ListLength -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) -- This type signature is needed, so GHC can infer the type of @MassInput{..}@, above
+          miDelete = error "miDelete"
+          miAllowAdd = error "miAllowAdd"
+          miButtonAction = error "miButtonAction"
+          postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId)
+          postProcess = Set.fromList . map fst . Map.elems
 
   runFormPost . identifyForm FIDCommunication $ renderAForm FormStandard $ Communication
     <$> recipientAForm
-    <*> areq textField (fslI MsgCommSubject) Nothing
+    <*> aopt textField (fslI MsgCommSubject) Nothing
 
+  error "commR"

src/Handler/Utils/Form.hs

@@ -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

@@ -29,7 +29,6 @@ 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))
 
 
@@ -407,4 +406,4 @@ massInputA :: forall handler cellData cellResult liveliness.
           -> 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
+  over _2 pure <$> massInput mi fs fvRequired initialResult mempty

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

@@ -47,6 +47,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.Binary            as Import (Binary)
 

src/Jobs/Types.hs

@@ -1,5 +1,6 @@
 module Jobs.Types
   ( Job(..), Notification(..)
+  , Communication(..)
   , JobCtl(..)
   , JobContext(..)
   ) where
@@ -34,20 +35,32 @@ 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
 
 
+data Communication = Communication
+ { cRecipients :: Set (Either UserEmail UserId)
+ , cSubject :: Maybe Text
+ } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Hashable Communication
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''Communication
+
+
 data JobCtl = JobCtlFlush
             | JobCtlPerform QueuedJobId
             | JobCtlDetermineCrontab

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

@@ -1,7 +1,7 @@
 module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation
-import Control.Lens as Utils.Lens hiding ((<.>))
+import Control.Lens as Utils.Lens hiding ((<.>), universe)
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
 
@@ -90,6 +90,8 @@ makeLenses_ ''StudyTerms
 
 makeLenses_ ''StudyTermCandidate
 
+makeLenses_ ''FieldView
+
 
 -- makeClassy_ ''Load
 

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

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