diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index b36af2378..71ac1bcd6 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -736,3 +736,7 @@ CommRecipients: Empfänger AddRecipientGroups: Empfängergruppen AddRecipientCustom: Weitere Empfänger + +RGCourseParticipants: Kursteilnehmer +RGCourseLecturers: Kursverwalter +RGCourseCorrectors: Korrektoren \ No newline at end of file diff --git a/routes b/routes index 391821721..d6b6e9236 100644 --- a/routes +++ b/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 diff --git a/src/Data/Set/Instances.hs b/src/Data/Set/Instances.hs new file mode 100644 index 000000000..9dc1c48cd --- /dev/null +++ b/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 diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 7e7d24522..fc07e9098 100644 --- a/src/Handler/Utils/Communication.hs +++ b/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 - universe = AddRecipientGroups: - [AddRecipientGroup g | g <- universe] - ++ [AddRecipientCustom] -instance Finite RecipientAddOptions +instance Universe RecipientAddOption where + universe = concat + [ pure AddRecipientGroups + , [ AddRecipientGroup g | g <- universe ] + , 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 - { cRecipients :: Set (Either Email UserId) - , cSubject :: Text - } - +-- `Communication` is defined in `Jobs.Types` 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)) - recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True Nothing - where miAdd _ _ nudge submitButton = Just $ \csrf -> do - let addOptions = Map.fromList . concat $ - [ pure (AddRecipientGroups, apreq (selectField . return $ mkOptionsList - [ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ] - ) ) - , do - (g,recs) <- Map.toList suggestedRecipients - return ( AddRecipientGroup g - , apreq (selectField . return $ mkOptionsList - [ Option userDisplayName (Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ] - ) - -- , pure (AddRecipientCustom, _ ) - ] - - - multiAction () - miCell - miDelete - miAllowAdd - miButtonAction + let recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) + recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True (Nothing {- TODO -}) + where + miAdd _ _ nudge submitView = Just $ \csrf -> do + let addOptions :: Map RecipientAddOption (AForm Handler (Set (Either UserEmail UserId))) + addOptions = Map.fromList . concat $ + [ pure ( AddRecipientGroups + , Set.unions <$> apreq (multiSelectField . return $ mkOptionList + [ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ] + ) ("" & addName (nudge . toPathPiece $ AddRecipientGroups)) Nothing + ) + , do + (g,recs) <- Map.toList suggestedRecipients + 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 + ) + -- , pure (AddRecipientCustom, _ ) + ] + (addRes, addWdgt) <- multiActionM addOptions ("" & addName (nudge "select")) Nothing csrf + error "miAdd" :: MForm Handler (FormResult (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))), Widget) + 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" diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 932044f62..61f4b5f1a 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 - let +sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template) + 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) -multiAction acts defAction = do + -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) +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 - widgets <- mapM mToWidget results - let actionWidgets = Map.foldrWithKey accWidget [] widgets - accWidget _act Nothing = id - accWidget act (Just w) = cons $(widgetFile "widgets/multi-action/multi-action") - actionResults = Map.map fst results - return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multi-action/multi-action-collect")) + + let actionResults = view _1 <$> results + actionViews = Map.foldrWithKey accViews [] results + + accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX] + accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd + + 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) - -> Maybe action - -> AForm (HandlerT UniWorX IO) a -multiActionA FieldSettings{..} acts defAction = formToAForm $ do - (res, selView) <- multiAction acts defAction + => Map action (AForm (HandlerT UniWorX IO) a) + -> FieldSettings UniWorX + -> Maybe action + -> AForm Handler a +multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty - 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 - } - ]) +multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) + => Map action (AForm (HandlerT UniWorX IO) a) + -> FieldSettings UniWorX + -> Maybe action + -> (Html -> MForm Handler (FormResult a, Widget)) +multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () formResultModal res finalDest handler = maybeT_ $ do diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 6f5e9f6dc..41402396f 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/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 \ No newline at end of file + over _2 pure <$> massInput mi fs fvRequired initialResult mempty diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index fc4e88574..2e980312f 100644 --- a/src/Handler/Utils/Rating.hs +++ b/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(..)) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 457682087..1fb803a6f 100644 --- a/src/Import/NoFoundation.hs +++ b/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) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 151d0e404..7e6019361 100644 --- a/src/Jobs/Types.hs +++ b/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 - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 , tagSingleConstructors = True , sumEncoding = TaggedObject "job" "data" } ''Job deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + { constructorTagModifier = camelToPathPiece' 1 + , 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 diff --git a/src/Utils.hs b/src/Utils.hs index 88adf17e4..a79e0a33b 100644 --- a/src/Utils.hs +++ b/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) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 0abc9a8ee..342f6a08f 100644 --- a/src/Utils/Lens.hs +++ b/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 diff --git a/templates/widgets/multi-action/multi-action-collect.hamlet b/templates/widgets/multi-action/multi-action-collect.hamlet deleted file mode 100644 index 480c54a63..000000000 --- a/templates/widgets/multi-action/multi-action-collect.hamlet +++ /dev/null @@ -1,4 +0,0 @@ -^{fvInput actionView} - -$forall w <- actionWidgets - ^{w}