From 4520c1be49098c5eb768c6162ffe0e71bff28ad8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 4 Apr 2019 15:59:45 +0200 Subject: [PATCH 01/19] email page form incomplete --- messages/uniworx/de.msg | 8 ++- routes | 1 + src/Handler/Course.hs | 11 +++- src/Handler/Utils/Communication.hs | 88 +++++++++++++++++++++++++++++ src/Handler/Utils/Form/MassInput.hs | 33 ++++++++--- src/Utils/Form.hs | 1 + src/Utils/Parameters.hs | 2 +- 7 files changed, 132 insertions(+), 12 deletions(-) create mode 100644 src/Handler/Utils/Communication.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e5eed4900..b36af2378 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -729,4 +729,10 @@ DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus de MassInputAddDimension: Hinzufügen MassInputDeleteCell: Entfernen -NavigationFavourites: Favoriten \ No newline at end of file +NavigationFavourites: Favoriten + +CommSubject: Betreff +CommRecipients: Empfänger + +AddRecipientGroups: Empfängergruppen +AddRecipientCustom: Weitere Empfänger diff --git a/routes b/routes index d558de967..391821721 100644 --- a/routes +++ b/routes @@ -78,6 +78,7 @@ /users CUsersR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET + /mail CCommR GET POST /notes CNotesR GET POST !corrector /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials !corrector diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5d4ec2bf9..3a2867f62 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -821,7 +821,7 @@ colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDeg foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) -data CourseUserAction = CourseUserDeregister +data CourseUserAction = CourseUserSendMail | CourseUserDeregister deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe CourseUserAction @@ -915,6 +915,9 @@ postCUsersR tid ssh csh = do table <- makeCourseUserTable cid colChoices psValidator return (ent, numParticipants, table) formResult participantRes $ \case + (CourseUserSendMail, selectedUsers) -> do + cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] + redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cid) | cid <- cids]) (CourseUserDeregister,selectedUsers) -> do nrDel <- runDB $ deleteWhereCount [ CourseParticipantCourse ==. cid @@ -1026,3 +1029,9 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -- If they are shared, adjust MsgCourseUserNoteTooltip getCNotesR = error "CNotesR: Not implemented" postCNotesR = error "CNotesR: Not implemented" + + + +getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCCommR = postCCommR +postCCommR tid ssh csh = commR _hole diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs new file mode 100644 index 000000000..7e7d24522 --- /dev/null +++ b/src/Handler/Utils/Communication.hs @@ -0,0 +1,88 @@ +module Handler.Utils.Communication where + +import Import + +import qualified Database.Esqueleto as E + +data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe RecipientGroup +instance Finite RecipientGroup +nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''RecipientGroup id + + +data RecipientAddOptions + = AddRecipientGroups + | AddRecipientGroup RecipientGroup + | AddRecipientCustom + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Universe RecipientAddOptions where + universe = AddRecipientGroups: + [AddRecipientGroup g | g <- universe] + ++ [AddRecipientCustom] +instance Finite RecipientAddOptions + +instance PathPiece RecipientAddOption where + toPathPiece AddRecipientGroups = "recipient-groups" + toPathPiece AddRecipientCustom = "recipient-custom" + toPathPiece (AddRecipientGroup g) = toPathPiece g + + fromPathPiece = finiteFromPathPiece + +instance RenderMessage UniWorX RecipientAddOption where + renderMessage foundation ls = \case + AddRecipientGroups -> renderMessage' MsgAddRecipientGroups + AddRecipientCustom -> renderMessage' MsgAddRecipientCustom + AddRecipientGroup g -> renderMessage' g + where renderMessage' = renderMessage foundation ls + + +data CommunicationRoute = CommuncationRoute + { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User))) + , crJob :: MailT Handler () -> Handler Job + } + +data Communication = Communication + { cRecipients :: Set (Either Email UserId) + , cSubject :: Text + } + + + +commR :: CommunicationRoute -> Handler Html +commR CommunicationRoute{..} = do + MsgRenderer mr <- getMsgRenderer + + suggestedRecipients' <- runDB $ traverse E.select crRecipients + suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> encrypt rid <*> pure ent + + let recipientAForm :: AForm (Set (Either Email UserId)) + recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True Nothing + where miAdd _ _ nudge submitButton = Just $ \csrf -> do + let addOptions = Map.fromList . concat $ + [ pure (AddRecipientGroups, apreq (selectField . return $ mkOptionsList + [ Option (mr g) (Set.fromList $ map (Right . entityKey . snd) recs) (toPathPiece g) | (g,recs) <- Map.toList suggestedRecipients ] + ) ) + , do + (g,recs) <- Map.toList suggestedRecipients + return ( AddRecipientGroup g + , apreq (selectField . return $ mkOptionsList + [ Option userDisplayName (Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ] + ) + -- , pure (AddRecipientCustom, _ ) + ] + + + multiAction () + miCell + miDelete + miAllowAdd + miButtonAction + + runFormPost . identifyForm FIDCommunication $ renderAForm FormStandard $ Communication + <$> recipientAForm + <*> areq textField (fslI MsgCommSubject) Nothing + diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index d1c403ec7..6f5e9f6dc 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -3,10 +3,11 @@ module Handler.Utils.Form.MassInput ( MassInput(..) , massInput - , massInputList , BoxDimension(..) , IsBoxCoord(..), boxDimension , Liveliness(..) + , massInputA + , massInputList , ListLength(..), ListPosition(..), miDeleteList ) where @@ -33,7 +34,7 @@ import Control.Monad.Reader.Class (MonadReader(local)) data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n) - + class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where boxDimensions :: [BoxDimension x] boxOrigin :: x @@ -47,7 +48,7 @@ boxDimension n -- zeroDimension :: IsBoxCoord x => Natural -> x -> x -- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim - + class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where type BoxCoord a :: * liveCoords :: Prism' (Set (BoxCoord a)) a @@ -221,12 +222,12 @@ massInput :: forall handler cellData cellResult liveliness. -> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX)) massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do let initialShape = fmap fst <$> initialResult - + miName <- maybe newFormIdent return fsName fvId <- maybe newIdent return fsId miAction <- traverse toTextUrl $ miButtonAction fvId let addFormAction = maybe id (addAttr "formaction") miAction - + let shapeName :: MassInputFieldName (BoxCoord liveliness) shapeName = MassInputShape{..} @@ -303,8 +304,8 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults shape <- if - | Just s <- addShape -> return s - | Just s <- delShape -> return s + | Just s <- addShape -> return s + | Just s <- delShape -> return s | otherwise -> return sentShape' liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness @@ -349,7 +350,7 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do cells | [] <- remDims = do coord <- coords - Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults + Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults let deleteButton = snd <$> Map.lookup coord delResults return (coord, $(widgetFile "widgets/massinput/cell")) | otherwise = @@ -360,7 +361,7 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions MsgRenderer mr <- getMsgRenderer - + let fvLabel = toHtml $ mr fsLabel fvTooltip = toHtml . mr <$> fsTooltip @@ -393,3 +394,17 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes miSettings miRequired (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult) + +massInputA :: forall handler cellData cellResult liveliness. + ( MonadHandler handler, HandlerSite handler ~ UniWorX + , ToJSON cellData, FromJSON cellData + , Liveliness liveliness + , MonadLogger handler + ) + => MassInput handler liveliness cellData cellResult + -> FieldSettings UniWorX + -> Bool -- ^ Required? + -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult)) + -> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult)) +massInputA mi fs fvRequired initialResult = formToAForm $ + over _2 pure <$> massInput mi fs fvRequired initialResult mempty \ No newline at end of file diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 96dec5423..1f207d484 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -189,6 +189,7 @@ data FormIdentifier | FIDcUserNote | FIDAdminDemo | FIDUserDelete + | FIDCommunication deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index 81b0c210a..5d5335a98 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -20,7 +20,7 @@ import Data.Universe import Control.Monad.Trans.Maybe (MaybeT(..)) -data GlobalGetParam = GetReferer +data GlobalGetParam = GetReferer | GetRecipient deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe GlobalGetParam From 5b6c35fedda596674d8a8f483fd2b698f0ee00c3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 15 Apr 2019 16:41:14 +0200 Subject: [PATCH 02/19] Cleanup --- messages/uniworx/de.msg | 4 + routes | 2 +- src/Data/Set/Instances.hs | 14 +++ src/Handler/Utils/Communication.hs | 93 +++++++++++-------- src/Handler/Utils/Form.hs | 86 ++++++----------- src/Handler/Utils/Form/MassInput.hs | 3 +- src/Handler/Utils/Rating.hs | 2 - src/Import/NoFoundation.hs | 1 + src/Jobs/Types.hs | 21 ++++- src/Utils.hs | 2 +- src/Utils/Lens.hs | 4 +- .../multi-action/multi-action-collect.hamlet | 4 - 12 files changed, 127 insertions(+), 109 deletions(-) create mode 100644 src/Data/Set/Instances.hs delete mode 100644 templates/widgets/multi-action/multi-action-collect.hamlet 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} From dd1cd6650f76955bacf0791dd88b152b9ac4de96 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 16 Apr 2019 15:03:37 +0200 Subject: [PATCH 03/19] communication prototype --- messages/uniworx/de.msg | 5 +++ src/Foundation.hs | 5 ++- src/Handler/Corrections.hs | 2 +- src/Handler/Course.hs | 33 +++++++++++++++- src/Handler/Help.hs | 2 +- src/Handler/SystemMessage.hs | 2 +- src/Handler/Utils/Communication.hs | 60 +++++++++++++++++++++++------- 7 files changed, 89 insertions(+), 20 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 44fad53b3..6f05189db 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -114,6 +114,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 @@ -738,6 +739,10 @@ NavigationFavourites: Favoriten CommSubject: Betreff CommRecipients: Empfänger +CommDuplicateRecipients recipients@TextList: #{pluralDE (length recipients) "Doppelter" "Doppelte"} Empfänger: #{intercalate ", " recipients} +CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt + +CommCourseHeading: Kursmitteilung AddRecipientGroups: Empfängergruppen AddRecipientCustom: Weitere Empfänger diff --git a/src/Foundation.hs b/src/Foundation.hs index f85e69e54..d7b14c2f9 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -173,8 +173,9 @@ noneOneMoreDE num noneText singularForm pluralForm | num == 1 = singularForm | otherwise = pluralForm --- Convenience Type for Messages -type IntMaybe = Maybe Int -- Yesod messages cannot deal with compound type identifiers +-- Convenience Type for Messages, since 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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 42c21d62a..b82a85ea0 100644 --- a/src/Handler/Corrections.hs +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 00b51056f..0a780b9ad 100644 --- a/src/Handler/Course.hs +++ b/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 @@ -930,7 +931,7 @@ postCUsersR tid ssh csh = do 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]) + redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) (CourseUserDeregister,selectedUsers) -> do nrDel <- runDB $ deleteWhereCount [ CourseParticipantCourse ==. cid @@ -1047,4 +1048,32 @@ postCNotesR = error "CNotesR: Not implemented" getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCCommR = postCCommR -postCCommR tid ssh csh = commR _hole +postCCommR tid ssh csh = do + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + + commR CommunicationRoute + { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading + , crUltDest = SomeRoute $ CourseR tid ssh csh CCommR + , crJob = error "job undefined" + , 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 + ) + ] + } diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index d29b7f214..788310888 100644 --- a/src/Handler/Help.hs +++ b/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 diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index c80ab32c0..8228136d4 100644 --- a/src/Handler/SystemMessage.hs +++ b/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 diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index fc07e9098..873781da7 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -1,17 +1,18 @@ module Handler.Utils.Communication where import Import -import Handler.Utils.Form +import Handler.Utils import Handler.Utils.Form.MassInput import Utils.Lens -import Jobs.Types +import Jobs.Queue +import Control.Monad.Trans.Reader (mapReaderT) import qualified Database.Esqueleto as E - +import qualified Data.CaseInsensitive as CI 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) @@ -56,14 +57,16 @@ instance RenderMessage UniWorX RecipientAddOption where data CommunicationRoute = CommunicationRoute { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User))) , crJob :: Communication -> DB Job + , crHeading :: SomeMessage UniWorX + , crUltDest :: SomeRoute UniWorX } - -- `Communication` is defined in `Jobs.Types` commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do MsgRenderer mr <- getMsgRenderer + mbCurrentRoute <- getCurrentRoute suggestedRecipients' <- runDB $ traverse E.select crRecipients suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> (encrypt rid :: Handler CryptoUUIDUser) <*> pure ent @@ -86,20 +89,51 @@ commR CommunicationRoute{..} = do [ Option userDisplayName (Set.singleton $ Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ] ) ("" & addName (nudge . toPathPiece $ AddRecipientGroup g)) Nothing ) - -- , pure (AddRecipientCustom, _ ) + , pure ( AddRecipientCustom + , Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField ("" & addName (nudge $ toPathPiece AddRecipientCustom)) Nothing ) ] (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" + -- lookupUserDisplayName :: UserId -> UserDisplayName + lookupUserDisplayName <- liftHandlerT . runDB $ do + let uids = toListOf (_FormSuccess . folded . _Right) addRes + names <- forM uids getJustEntity + return $ \uid -> case filter ((== uid) . entityKey) names of + [Entity _ User{..}] -> userDisplayName + _other -> error "UserId lookpup failed" + let addRes' = addRes <&> \newSet oldMap -> if + | collisions <- newSet `Set.intersection` Set.fromList (Map.elems oldMap) + , not $ Set.null collisions -> + FormFailure [ mr . MsgCommDuplicateRecipients . map (either CI.original lookupUserDisplayName) $ Set.toList collisions ] + | otherwise -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList newSet + + addWdgt' = mconcat [ toWidget csrf, addWdgt, fvInput submitView ] + return (addRes', addWdgt') + + miCell _ (Left email) _ _nudge csrf + = return (pure (), toWidget csrf <> toWidget (mailtoHtml email)) + miCell _ (Right rid) _ _nudge csrf = do + User{..} <- liftHandlerT . runDB $ getJust rid + return (pure (), toWidget csrf <> nameEmailWidget userEmail userDisplayName userSurname) 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" + miDelete = miDeleteList -- default for lists suffices, since there are no restrictions + miAllowAdd _ _ _ = True + miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId) postProcess = Set.fromList . map fst . Map.elems - runFormPost . identifyForm FIDCommunication $ renderAForm FormStandard $ Communication + ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication <$> recipientAForm <*> aopt textField (fslI MsgCommSubject) Nothing + formResult commRes $ \comm -> do + runDBJobs $ queueDBJob =<< mapReaderT lift (crJob comm) + addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm + redirect crUltDest - error "commR" + + let formWdgt = wrapForm commWdgt def + { formMethod = POST + , formAction = SomeRoute <$> mbCurrentRoute + , formEncoding = commEncoding + } + siteLayoutMsg crHeading formWdgt From 529b2f22c4b467fc503a7469aebc012128d3aad4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 16 Apr 2019 15:22:16 +0200 Subject: [PATCH 04/19] filter duplicate recipients silently --- messages/uniworx/de.msg | 2 +- src/Handler/Utils/Communication.hs | 34 +++++++++++++++++------------- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 6f05189db..84c01ecaa 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -739,7 +739,7 @@ NavigationFavourites: Favoriten CommSubject: Betreff CommRecipients: Empfänger -CommDuplicateRecipients recipients@TextList: #{pluralDE (length recipients) "Doppelter" "Doppelte"} Empfänger: #{intercalate ", " recipients} +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 diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 873781da7..dc8d6fe54 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -80,31 +80,35 @@ commR CommunicationRoute{..} = do [ 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 + ) (fslI AddRecipientGroups & 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 + ) (fslI (AddRecipientGroup g) & addName (nudge . toPathPiece $ AddRecipientGroup g)) Nothing ) , pure ( AddRecipientCustom - , Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField ("" & addName (nudge $ toPathPiece AddRecipientCustom)) Nothing ) + , Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField (fslI AddRecipientCustom & addName (nudge $ toPathPiece AddRecipientCustom)) Nothing ) ] - (addRes, addWdgt) <- multiActionM addOptions ("" & addName (nudge "select")) Nothing csrf + (addRes, addWdgt) <- multiActionM addOptions ("foobar" & addName (nudge "select")) Nothing csrf -- lookupUserDisplayName :: UserId -> UserDisplayName - lookupUserDisplayName <- liftHandlerT . runDB $ do - let uids = toListOf (_FormSuccess . folded . _Right) addRes - names <- forM uids getJustEntity - return $ \uid -> case filter ((== uid) . entityKey) names of - [Entity _ User{..}] -> userDisplayName - _other -> error "UserId lookpup failed" - let addRes' = addRes <&> \newSet oldMap -> if - | collisions <- newSet `Set.intersection` Set.fromList (Map.elems oldMap) - , not $ Set.null collisions -> - FormFailure [ mr . MsgCommDuplicateRecipients . map (either CI.original lookupUserDisplayName) $ Set.toList collisions ] - | otherwise -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList newSet + -- lookupUserDisplayName <- liftHandlerT . runDB $ do + -- let uids = toListOf (_FormSuccess . folded . _Right) addRes + -- names <- forM uids getJustEntity + -- return $ \uid -> case filter ((== uid) . entityKey) names of + -- [Entity _ User{..}] -> userDisplayName + -- _other -> error "UserId lookpup failed" + let addRes' = addRes <&> \newSet oldMap -> + -- if + -- | collisions <- newSet `Set.intersection` Set.fromList (Map.elems oldMap) + -- , not $ Set.null collisions -> + -- -- FormFailure [ mr . MsgCommDuplicateRecipients . map (either CI.original lookupUserDisplayName) $ Set.toList collisions ] + -- FormFailure [ mr . MsgCommDuplicateRecipients $ Set.size collisions ] + -- | otherwise -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList newSet + let freshSet = newSet `Set.difference` Set.fromList (Map.elems oldMap) + in FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList freshSet addWdgt' = mconcat [ toWidget csrf, addWdgt, fvInput submitView ] return (addRes', addWdgt') From 80e67996e6309e1868453d582b78a4cba06c9971 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 16 Apr 2019 15:38:19 +0200 Subject: [PATCH 05/19] Adjust `interactiveFieldsetUtil` for flatter `multiAction` --- static/js/utils/form.js | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/static/js/utils/form.js b/static/js/utils/form.js index cb7cdd9f9..9c577725a 100644 --- a/static/js/utils/form.js +++ b/static/js/utils/form.js @@ -145,6 +145,7 @@ var interactiveFieldsetUtil = function(element) { var conditionalInput; var conditionalValue; + var formGroup; function init() { if (!element) { @@ -171,6 +172,11 @@ } conditionalValue = element.dataset.conditionalValue; + formGroup = element.closest('.form-group'); + if (!formGroup) { + throw new Error('Interactive Fieldset needs a .form-group ancestor!'); + } + // add event listener conditionalInput.addEventListener('input', updateVisibility); @@ -188,7 +194,7 @@ } function updateVisibility() { - element.classList.toggle('hidden', conditionalInput.value !== conditionalValue); + formGroup.classList.toggle('hidden', conditionalInput.value !== conditionalValue); } return init(); From c229a013767f4d9605fd74eb46f5eb8e4202be9e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 16 Apr 2019 15:39:21 +0200 Subject: [PATCH 06/19] cbody added --- messages/uniworx/de.msg | 2 ++ src/Handler/Utils/Communication.hs | 21 ++++----------------- src/Jobs/Types.hs | 1 + 3 files changed, 7 insertions(+), 17 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 84c01ecaa..a809cde7e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -738,7 +738,9 @@ MassInputDeleteCell: Entfernen NavigationFavourites: Favoriten CommSubject: Betreff +CommBody: Nachricht CommRecipients: Empfänger +CommRecipientsSelectBy: Auswahl nach CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index dc8d6fe54..abc9d4ed0 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -92,24 +92,10 @@ commR CommunicationRoute{..} = do , pure ( AddRecipientCustom , Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField (fslI AddRecipientCustom & addName (nudge $ toPathPiece AddRecipientCustom)) Nothing ) ] - (addRes, addWdgt) <- multiActionM addOptions ("foobar" & addName (nudge "select")) Nothing csrf - -- lookupUserDisplayName :: UserId -> UserDisplayName - -- lookupUserDisplayName <- liftHandlerT . runDB $ do - -- let uids = toListOf (_FormSuccess . folded . _Right) addRes - -- names <- forM uids getJustEntity - -- return $ \uid -> case filter ((== uid) . entityKey) names of - -- [Entity _ User{..}] -> userDisplayName - -- _other -> error "UserId lookpup failed" + (addRes, addWdgt) <- multiActionM addOptions (fslI MsgCommRecipientsSelectBy & addName (nudge "select")) Nothing csrf let addRes' = addRes <&> \newSet oldMap -> - -- if - -- | collisions <- newSet `Set.intersection` Set.fromList (Map.elems oldMap) - -- , not $ Set.null collisions -> - -- -- FormFailure [ mr . MsgCommDuplicateRecipients . map (either CI.original lookupUserDisplayName) $ Set.toList collisions ] - -- FormFailure [ mr . MsgCommDuplicateRecipients $ Set.size collisions ] - -- | otherwise -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList newSet - let freshSet = newSet `Set.difference` Set.fromList (Map.elems oldMap) - in FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList freshSet - + let freshSet = newSet `Set.difference` Set.fromList (Map.elems oldMap) + in FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList freshSet addWdgt' = mconcat [ toWidget csrf, addWdgt, fvInput submitView ] return (addRes', addWdgt') @@ -129,6 +115,7 @@ commR CommunicationRoute{..} = do ((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 $ queueDBJob =<< mapReaderT lift (crJob comm) addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 0aa6afe47..a7b1c7c27 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -55,6 +55,7 @@ deriveJSON defaultOptions data Communication = Communication { cRecipients :: Set (Either UserEmail UserId) , cSubject :: Maybe Text + , cBody :: Html } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Hashable Communication From 6f4b09bb0ad6fe814f5cf39299f31b9d92f70b89 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 16 Apr 2019 15:51:03 +0200 Subject: [PATCH 07/19] Instances for Html --- src/Import/NoFoundation.hs | 2 ++ src/Text/Blaze/Instances.hs | 37 +++++++++++++++++++++++++++++++++++++ 2 files changed, 39 insertions(+) create mode 100644 src/Text/Blaze/Instances.hs diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 74f6f10bd..767067ba1 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -69,6 +69,8 @@ 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 Control.Monad.Trans.RWS (RWST) diff --git a/src/Text/Blaze/Instances.hs b/src/Text/Blaze/Instances.hs new file mode 100644 index 000000000..346b17c60 --- /dev/null +++ b/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 From 8637847fc6c1bbd624ebecf5d5d6d64a0b6c0a6c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 16 Apr 2019 21:28:21 +0200 Subject: [PATCH 08/19] Working CCommR --- messages/uniworx/de.msg | 8 +++ src/Foundation.hs | 17 +++++- src/Handler/Course.hs | 15 ++++- src/Handler/Help.hs | 4 +- src/Handler/Utils/Communication.hs | 41 +++++++++---- src/Handler/Utils/Form.hs | 2 +- src/Handler/Utils/Mail.hs | 15 ++--- src/Import/NoFoundation.hs | 2 +- src/Jobs.hs | 1 + src/Jobs/Handler/HelpRequest.hs | 4 +- src/Jobs/Handler/SendCourseCommunication.hs | 37 ++++++++++++ src/Jobs/Queue.hs | 28 +++++++-- src/Jobs/Types.hs | 26 ++++----- src/Mail.hs | 64 +++++++++++++++------ src/Utils/Parameters.hs | 13 ++++- 15 files changed, 208 insertions(+), 69 deletions(-) create mode 100644 src/Jobs/Handler/SendCourseCommunication.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index a809cde7e..569697d3f 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -516,6 +516,8 @@ MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject} +CommCourseSubject: Kursmitteilung + SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten @@ -670,6 +672,7 @@ MenuLogin: Login MenuLogout: Logout MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer +MenuCourseCommunication: Kursmitteilung MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer @@ -740,7 +743,9 @@ NavigationFavourites: Favoriten CommSubject: Betreff CommBody: Nachricht CommRecipients: Empfänger +CommRecipientsTip: Sie können die Liste von Empfängern beliebig bearbeiten, bevor Sie die Nachricht verschicken. Sie selbst erhalten immer eine Kopie der Nachricht. CommRecipientsSelectBy: Auswahl nach +CommRecipientsSelectByTip: Mögliche Empfänger sind in verschiedene Gruppen unterteilt; sie können sowohl ganze Empfängergruppen als auch einzelne Mitglieder von Empfängergruppen hinzufügen CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt @@ -752,3 +757,6 @@ AddRecipientCustom: 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 \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index d7b14c2f9..8623fd45a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1172,6 +1172,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) @@ -1539,6 +1540,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 @@ -2227,11 +2236,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 . addressEmail =<< getsYesod (appMailFrom . appSettings) - mail <* setMailSmtpData + (mRes, smtpData) <- listen mail + unless (view _MailSmtpDataSet smtpData) + setMailSmtpData + + return mRes instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 0a780b9ad..6984e6e57 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1049,12 +1049,23 @@ postCNotesR = error "CNotesR: Not implemented" getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCCommR = postCCommR postCCommR tid ssh csh = do - cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + 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 - , crJob = error "job undefined" + , 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 diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index 788310888..f79d36b92 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -53,8 +53,8 @@ postHelpR = do now <- liftIO getCurrentTime hfReferer' <- traverse toTextUrl hfReferer queueJob' JobHelpRequest - { jSender = hfUserId - , jHelpSubject = hfSubject + { jHelpSender = hfUserId + , jSubject = hfSubject , jHelpRequest = hfRequest , jRequestTime = now , jReferer = hfReferer' diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index abc9d4ed0..88dbccf55 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -1,4 +1,11 @@ -module Handler.Utils.Communication where +module Handler.Utils.Communication + ( RecipientGroup(..) + , CommunicationRoute(..) + , Communication(..) + , commR + -- * Re-Exports + , Job(..) + ) where import Import import Handler.Utils @@ -56,23 +63,32 @@ instance RenderMessage UniWorX RecipientAddOption where data CommunicationRoute = CommunicationRoute { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User))) - , crJob :: Communication -> DB Job + , crJobs :: Communication -> Source (YesodDB UniWorX) Job , crHeading :: SomeMessage UniWorX , crUltDest :: SomeRoute UniWorX } --- `Communication` is defined in `Jobs.Types` + +data Communication = Communication + { cRecipients :: Set (Either UserEmail UserId) + , cSubject :: Maybe Text + , cBody :: Html + } commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do + uid <- maybeAuthId + MsgRenderer mr <- getMsgRenderer mbCurrentRoute <- getCurrentRoute suggestedRecipients' <- runDB $ traverse E.select crRecipients suggestedRecipients <- forM suggestedRecipients' . mapM $ \ent@(Entity rid _) -> (,) <$> (encrypt rid :: Handler CryptoUUIDUser) <*> pure ent + chosenRecipients <- fmap (maybe id cons uid) $ mapM (decrypt :: CryptoUUIDUser -> Handler UserId) =<< lookupGlobalGetParams GetRecipient + let recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) - recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients) True (Nothing {- TODO -}) + recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just . Map.fromList . zip [0..] $ map ((, ()) . Right) chosenRecipients) where miAdd _ _ nudge submitView = Just $ \csrf -> do let addOptions :: Map RecipientAddOption (AForm Handler (Set (Either UserEmail UserId))) @@ -80,19 +96,20 @@ commR CommunicationRoute{..} = do [ 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 ] - ) (fslI AddRecipientGroups & addName (nudge . toPathPiece $ AddRecipientGroups)) Nothing + ) (fslI AddRecipientGroups & addName (nudge . toPathPiece $ AddRecipientGroups) & setTooltip MsgMultiSelectFieldTip) Nothing ) , do - (g,recs) <- Map.toList suggestedRecipients + (g, recs) <- Map.toList suggestedRecipients + guard . not $ null recs return ( AddRecipientGroup g , Set.unions <$> apreq (multiSelectField . return $ mkOptionList [ Option userDisplayName (Set.singleton $ Right rid) (toPathPiece cid) | (cid, Entity rid User{..}) <- recs ] - ) (fslI (AddRecipientGroup g) & addName (nudge . toPathPiece $ AddRecipientGroup g)) Nothing + ) (fslI (AddRecipientGroup g) & addName (nudge . toPathPiece $ AddRecipientGroup g) & setTooltip MsgMultiSelectFieldTip) Nothing ) , pure ( AddRecipientCustom - , Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField (fslI AddRecipientCustom & addName (nudge $ toPathPiece AddRecipientCustom)) Nothing ) + , Set.fromList . map (Left . CI.mk) <$> apreq multiEmailField (fslI AddRecipientCustom & addName (nudge $ toPathPiece AddRecipientCustom) & setTooltip MsgMultiEmailFieldTip) Nothing ) ] - (addRes, addWdgt) <- multiActionM addOptions (fslI MsgCommRecipientsSelectBy & addName (nudge "select")) Nothing csrf + (addRes, addWdgt) <- multiActionM addOptions (fslI MsgCommRecipientsSelectBy & addName (nudge "select") & setTooltip MsgCommRecipientsSelectByTip) Nothing csrf let addRes' = addRes <&> \newSet oldMap -> let freshSet = newSet `Set.difference` Set.fromList (Map.elems oldMap) in FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) (Map.lookupMax oldMap)..] $ Set.toList freshSet @@ -117,7 +134,7 @@ commR CommunicationRoute{..} = do <*> aopt textField (fslI MsgCommSubject) Nothing <*> areq htmlField (fslI MsgCommBody) Nothing formResult commRes $ \comm -> do - runDBJobs $ queueDBJob =<< mapReaderT lift (crJob comm) + runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm redirect crUltDest @@ -127,4 +144,6 @@ commR CommunicationRoute{..} = do , formAction = SomeRoute <$> mbCurrentRoute , formEncoding = commEncoding } - siteLayoutMsg crHeading formWdgt + siteLayoutMsg crHeading $ do + setTitleI crHeading + formWdgt diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 61f4b5f1a..c37007add 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 5c35dd4aa..02af114b7 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -1,5 +1,6 @@ module Handler.Utils.Mail ( addRecipientsDB + , userAddress , userMailT , addFileDB ) where @@ -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 - { userEmail - , userDisplayName - , userMailLanguages + user@User + { 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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 767067ba1..416547c54 100644 --- a/src/Import/NoFoundation.hs +++ b/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 diff --git a/src/Jobs.hs b/src/Jobs.hs index 2a9a42556..5f4895a29 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -58,6 +58,7 @@ import Jobs.Handler.QueueNotification import Jobs.Handler.HelpRequest import Jobs.Handler.SetLogSettings import Jobs.Handler.DistributeCorrections +import Jobs.Handler.SendCourseCommunication data JobQueueException = JInvalid QueuedJobId QueuedJob diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index 2b92c0e2b..a792b22b6 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/src/Jobs/Handler/HelpRequest.hs @@ -23,13 +23,13 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do supportAddress <- getsYesod $ appMailSupport . appSettings 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 diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs new file mode 100644 index 000000000..734612c43 --- /dev/null +++ b/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 diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index a9d701ec4..b91a51d1d 100644 --- a/src/Jobs/Queue.hs +++ b/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) - => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a +sinkDBJobs :: Sink Job (YesodJobDB UniWorX) () +-- | 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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index a7b1c7c27..58fa39e48 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -1,6 +1,5 @@ module Jobs.Types ( Job(..), Notification(..) - , Communication(..) , JobCtl(..) , JobContext(..) ) where @@ -16,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 + } deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } @@ -52,19 +59,6 @@ deriveJSON defaultOptions } ''Notification -data Communication = Communication - { cRecipients :: Set (Either UserEmail UserId) - , cSubject :: Maybe Text - , cBody :: Html - } 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/Mail.hs b/src/Mail.hs index 008af9987..68d798336 100644 --- a/src/Mail.hs +++ b/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 , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts @@ -60,18 +63,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) @@ -104,6 +108,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_ ''Mail makeLenses_ ''Part @@ -131,6 +141,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) @@ -424,20 +441,33 @@ setMailObjectUUID uuid = do replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">" return objectId -setMailObjectId :: ( MonadHeader m - , YesodMail (HandlerSite m) - ) => m MailObjectId -setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom +setMailObjectIdRandom :: ( MonadHeader m + , YesodMail (HandlerSite m) + ) => m MailObjectId +setMailObjectIdRandom = setMailObjectUUID =<< liftIO getRandom -setMailObjectId' :: ( MonadHeader m - , YesodMail (HandlerSite m) - , MonadCrypto m - , HasCryptoUUID plain m - , MonadCryptoKey m ~ CryptoIDKey - , KnownSymbol (CryptoIDNamespace UUID plain) - , Binary plain - ) => plain -> m MailObjectId -setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid +setMailObjectIdCrypto :: ( MonadHeader m + , YesodMail (HandlerSite m) + , MonadCrypto m + , HasCryptoUUID plain m + , MonadCryptoKey m ~ CryptoIDKey + , KnownSymbol (CryptoIDNamespace UUID plain) + , Binary plain + ) => plain -> m MailObjectId +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 () diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index 5d5335a98..727dfa04f 100644 --- a/src/Utils/Parameters.hs +++ b/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 @@ -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 @@ -62,7 +65,11 @@ 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 From 9f5406d284beb29caae5d145a0beb5725160e9f8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 17 Apr 2019 14:06:41 +0200 Subject: [PATCH 09/19] Custom styling for massInput --- src/Handler/Admin.hs | 2 +- src/Handler/Course.hs | 30 ++++------ src/Handler/Utils/Form/MassInput.hs | 56 +++++++++++++------ templates/course/lecturerMassInput/add.hamlet | 6 ++ .../lecturerMassInput/cellInvitation.hamlet | 12 ++++ .../course/lecturerMassInput/cellKnown.hamlet | 6 ++ .../course/lecturerMassInput/layout.hamlet | 11 ++++ .../widgets/massinput/list/layout.hamlet | 14 +++++ 8 files changed, 101 insertions(+), 36 deletions(-) create mode 100644 templates/course/lecturerMassInput/add.hamlet create mode 100644 templates/course/lecturerMassInput/cellInvitation.hamlet create mode 100644 templates/course/lecturerMassInput/cellKnown.hamlet create mode 100644 templates/course/lecturerMassInput/layout.hamlet create mode 100644 templates/widgets/massinput/list/layout.hamlet diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 32f8db822..a47cce3b7 100644 --- a/src/Handler/Admin.hs +++ b/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 buttonAction defaultMiLayout) "" True Nothing let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index c084c139f..3b9dd0790 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -27,6 +27,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 +638,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 - #{csrf} - ^{nameEmailWidget userEmail userDisplayName userSurname} # - ^{fvInput lrwView} - |] + let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") return (Just <$> lrwRes,lrwView') miCell _ (Left lEmail) defType nudge = \csrf -> do (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType - let lrwView' = [whamlet| - $newline never - #{csrf} - - #{lEmail} - # -
-
-
- _{MsgEmailInvitationWarning} - # - ^{fvInput lrwView} - |] + let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") return (lrwRes,lrwView') miDelete :: ListLength -- ^ Current shape @@ -675,6 +660,13 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ _ = True + miLayout :: ListLength + -> 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 diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index d1c403ec7..a30c5010b 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -2,6 +2,7 @@ module Handler.Utils.Form.MassInput ( MassInput(..) + , defaultMiLayout , massInput , massInputList , BoxDimension(..) @@ -24,6 +25,7 @@ import Text.Blaze (Markup) import qualified Data.Text as Text import qualified Data.Set as Set +import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Foldable as Fold import Data.List (genericLength, genericIndex, iterate) @@ -206,6 +208,11 @@ data MassInput handler liveliness cellData cellResult = MassInput -> liveliness -> Bool -- ^ Decide whether an addition-operation should be permitted , 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) Widget -- ^ Cell Widgets + -> Map (BoxCoord liveliness) (FieldView UniWorX) -- ^ Delete buttons + -> Map (Natural, BoxCoord liveliness) Widget -- ^ Addition forms + -> Widget } massInput :: forall handler cellData cellResult liveliness. @@ -342,22 +349,12 @@ 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 - miWidget' _ [] = mempty - miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) = - let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord - cells - | [] <- remDims = do - coord <- coords - 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 + let miWidget + = miLayout + liveliness + (fmap (view $ _2 . _2) cellResults) + (fmap (view _2) delResults) + (Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults) MsgRenderer mr <- getMsgRenderer @@ -368,6 +365,31 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do fvErrors = Nothing in return (result, FieldView{..}) +defaultMiLayout :: forall liveliness. + Liveliness liveliness + => liveliness + -> 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))] -> Widget + miWidget' _ [] = mempty + miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) = + let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord + 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 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. @@ -389,6 +411,8 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes , miDelete = miDeleteList , miAllowAdd = \_ _ _ -> True , miButtonAction + , miLayout = \lLength cellWdgts delButtons addWdgts + -> $(widgetFile "widgets/massinput/list/layout") } miSettings miRequired diff --git a/templates/course/lecturerMassInput/add.hamlet b/templates/course/lecturerMassInput/add.hamlet new file mode 100644 index 000000000..da5411bc4 --- /dev/null +++ b/templates/course/lecturerMassInput/add.hamlet @@ -0,0 +1,6 @@ +$newline never + + #{csrf} + ^{fvInput addView} + + ^{fvInput btn} diff --git a/templates/course/lecturerMassInput/cellInvitation.hamlet b/templates/course/lecturerMassInput/cellInvitation.hamlet new file mode 100644 index 000000000..523d9577b --- /dev/null +++ b/templates/course/lecturerMassInput/cellInvitation.hamlet @@ -0,0 +1,12 @@ + $newline never + + #{csrf} + + #{lEmail} + +
+
+
+ _{MsgEmailInvitationWarning} + + ^{fvInput lrwView} diff --git a/templates/course/lecturerMassInput/cellKnown.hamlet b/templates/course/lecturerMassInput/cellKnown.hamlet new file mode 100644 index 000000000..0b55c7902 --- /dev/null +++ b/templates/course/lecturerMassInput/cellKnown.hamlet @@ -0,0 +1,6 @@ +$newline never + + #{csrf} + ^{nameEmailWidget userEmail userDisplayName userSurname} # + + ^{fvInput lrwView} diff --git a/templates/course/lecturerMassInput/layout.hamlet b/templates/course/lecturerMassInput/layout.hamlet new file mode 100644 index 000000000..8dc00bc90 --- /dev/null +++ b/templates/course/lecturerMassInput/layout.hamlet @@ -0,0 +1,11 @@ +$newline never + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/massinput/list/layout.hamlet b/templates/widgets/massinput/list/layout.hamlet new file mode 100644 index 000000000..5f5676bb6 --- /dev/null +++ b/templates/widgets/massinput/list/layout.hamlet @@ -0,0 +1,14 @@ +$newline never +
+ ^{fvInput (delButtons ! coord)} +
+ + + $forall coord <- review liveCoords lLength + + +
+ ^{cellWdgts ! coord} + + ^{fvInput (delButtons ! coord)} +
+ + ^{addWdgts ! (0, 0)} From 7bae03b4c056a8e99596307c4a9dce6558f36f13 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 17 Apr 2019 14:23:20 +0200 Subject: [PATCH 10/19] Use available constant in interactive fieldset utility --- static/js/utils/form.js | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/static/js/utils/form.js b/static/js/utils/form.js index 9c577725a..d4f97bb4a 100644 --- a/static/js/utils/form.js +++ b/static/js/utils/form.js @@ -3,6 +3,10 @@ var formUtilities = []; + var FORM_GROUP_SELECTOR = '.form-group'; + var FORM_GROUP_WITH_ERRORS_CLASS = 'form-group--has-error'; + + /** * * Reactive Submit Button Utility @@ -172,7 +176,7 @@ } conditionalValue = element.dataset.conditionalValue; - formGroup = element.closest('.form-group'); + formGroup = element.closest(FORM_GROUP_SELECTOR); if (!formGroup) { throw new Error('Interactive Fieldset needs a .form-group ancestor!'); } @@ -263,9 +267,6 @@ var FORM_ERROR_REMOVER_INITIALIZED_CLASS = 'form-error-remover--initialized'; var FORM_ERROR_REMOVER_INPUTS_SELECTOR = 'input:not([type="hidden"]), textarea, select'; - var FORM_GROUP_SELECTOR = '.form-group'; - var FORM_GROUP_WITH_ERRORS_CLASS = 'form-group--has-error'; - var formErrorRemoverUtil = function(element) { var formGroups; From 76f984420f4f7f94523c77c1a1a18b45287184e8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 17 Apr 2019 14:06:41 +0200 Subject: [PATCH 11/19] Custom styling for massInput --- src/Handler/Admin.hs | 2 +- src/Handler/Course.hs | 30 ++++------ src/Handler/Utils/Communication.hs | 1 + src/Handler/Utils/Form/MassInput.hs | 56 +++++++++++++------ templates/course/lecturerMassInput/add.hamlet | 6 ++ .../lecturerMassInput/cellInvitation.hamlet | 12 ++++ .../course/lecturerMassInput/cellKnown.hamlet | 6 ++ .../course/lecturerMassInput/layout.hamlet | 11 ++++ .../widgets/massinput/list/layout.hamlet | 14 +++++ 9 files changed, 102 insertions(+), 36 deletions(-) create mode 100644 templates/course/lecturerMassInput/add.hamlet create mode 100644 templates/course/lecturerMassInput/cellInvitation.hamlet create mode 100644 templates/course/lecturerMassInput/cellKnown.hamlet create mode 100644 templates/course/lecturerMassInput/layout.hamlet create mode 100644 templates/widgets/massinput/list/layout.hamlet diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 32f8db822..a47cce3b7 100644 --- a/src/Handler/Admin.hs +++ b/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 buttonAction defaultMiLayout) "" True Nothing let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 79525232d..1a866936e 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -28,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 @@ -638,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 - #{csrf} - ^{nameEmailWidget userEmail userDisplayName userSurname} # - ^{fvInput lrwView} - |] + let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") return (Just <$> lrwRes,lrwView') miCell _ (Left lEmail) defType nudge = \csrf -> do (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType - let lrwView' = [whamlet| - $newline never - #{csrf} - - #{lEmail} - # -
-
-
- _{MsgEmailInvitationWarning} - # - ^{fvInput lrwView} - |] + let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") return (lrwRes,lrwView') miDelete :: ListLength -- ^ Current shape @@ -676,6 +661,13 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ _ = True + miLayout :: ListLength + -> 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 diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 88dbccf55..6d4527402 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -126,6 +126,7 @@ commR CommunicationRoute{..} = do miAllowAdd _ _ _ = True miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute + miLayout = defaultMiLayout postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId) postProcess = Set.fromList . map fst . Map.elems diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 41402396f..ca23fd041 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -2,6 +2,7 @@ module Handler.Utils.Form.MassInput ( MassInput(..) + , defaultMiLayout , massInput , BoxDimension(..) , IsBoxCoord(..), boxDimension @@ -25,6 +26,7 @@ import Text.Blaze (Markup) import qualified Data.Text as Text import qualified Data.Set as Set +import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Foldable as Fold import Data.List (genericLength, genericIndex, iterate) @@ -206,6 +208,11 @@ data MassInput handler liveliness cellData cellResult = MassInput -> liveliness -> Bool -- ^ Decide whether an addition-operation should be permitted , 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) Widget -- ^ Cell Widgets + -> Map (BoxCoord liveliness) (FieldView UniWorX) -- ^ Delete buttons + -> Map (Natural, BoxCoord liveliness) Widget -- ^ Addition forms + -> Widget } massInput :: forall handler cellData cellResult liveliness. @@ -342,22 +349,12 @@ 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 - miWidget' _ [] = mempty - miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) = - let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord - cells - | [] <- remDims = do - coord <- coords - 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 + let miWidget + = miLayout + liveliness + (fmap (view $ _2 . _2) cellResults) + (fmap (view _2) delResults) + (Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults) MsgRenderer mr <- getMsgRenderer @@ -368,6 +365,31 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do fvErrors = Nothing in return (result, FieldView{..}) +defaultMiLayout :: forall liveliness. + Liveliness liveliness + => liveliness + -> 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))] -> Widget + miWidget' _ [] = mempty + miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) = + let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord + 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 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. @@ -389,6 +411,8 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes , miDelete = miDeleteList , miAllowAdd = \_ _ _ -> True , miButtonAction + , miLayout = \lLength cellWdgts delButtons addWdgts + -> $(widgetFile "widgets/massinput/list/layout") } miSettings miRequired diff --git a/templates/course/lecturerMassInput/add.hamlet b/templates/course/lecturerMassInput/add.hamlet new file mode 100644 index 000000000..da5411bc4 --- /dev/null +++ b/templates/course/lecturerMassInput/add.hamlet @@ -0,0 +1,6 @@ +$newline never +
 + #{csrf} + ^{fvInput addView} + + ^{fvInput btn} diff --git a/templates/course/lecturerMassInput/cellInvitation.hamlet b/templates/course/lecturerMassInput/cellInvitation.hamlet new file mode 100644 index 000000000..523d9577b --- /dev/null +++ b/templates/course/lecturerMassInput/cellInvitation.hamlet @@ -0,0 +1,12 @@ + $newline never + + #{csrf} + + #{lEmail} + +
+
+
+ _{MsgEmailInvitationWarning} +
+ ^{fvInput lrwView} diff --git a/templates/course/lecturerMassInput/cellKnown.hamlet b/templates/course/lecturerMassInput/cellKnown.hamlet new file mode 100644 index 000000000..0b55c7902 --- /dev/null +++ b/templates/course/lecturerMassInput/cellKnown.hamlet @@ -0,0 +1,6 @@ +$newline never + + #{csrf} + ^{nameEmailWidget userEmail userDisplayName userSurname} # + + ^{fvInput lrwView} diff --git a/templates/course/lecturerMassInput/layout.hamlet b/templates/course/lecturerMassInput/layout.hamlet new file mode 100644 index 000000000..8dc00bc90 --- /dev/null +++ b/templates/course/lecturerMassInput/layout.hamlet @@ -0,0 +1,11 @@ +$newline never + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/massinput/list/layout.hamlet b/templates/widgets/massinput/list/layout.hamlet new file mode 100644 index 000000000..5f5676bb6 --- /dev/null +++ b/templates/widgets/massinput/list/layout.hamlet @@ -0,0 +1,14 @@ +$newline never +
+ ^{fvInput (delButtons ! coord)} +
+ + + $forall coord <- review liveCoords lLength + + +
+ ^{cellWdgts ! coord} + + ^{fvInput (delButtons ! coord)} +
+ + ^{addWdgts ! (0, 0)} From 11d2cc46a8ab3d3703bc7c49123ee9aa0c50f2f2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 18 Apr 2019 16:07:21 +0200 Subject: [PATCH 12/19] Minor refactor --- src/Handler/Utils/Form/MassInput.hs | 76 +++++++++++-------- .../Utils/Form/MassInput/Liveliness.hs | 45 +++++++++++ 2 files changed, 91 insertions(+), 30 deletions(-) create mode 100644 src/Handler/Utils/Form/MassInput/Liveliness.hs diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index ca23fd041..e30c061ee 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -4,18 +4,18 @@ module Handler.Utils.Form.MassInput ( MassInput(..) , defaultMiLayout , massInput - , BoxDimension(..) - , IsBoxCoord(..), boxDimension - , Liveliness(..) + , module Handler.Utils.Form.MassInput.Liveliness , massInputA , massInputList , ListLength(..), ListPosition(..), miDeleteList + , EnumLiveliness(..), EnumPosition(..) ) where import Import import Utils.Form import Utils.Lens import Handler.Utils.Form (secretJsonField) +import Handler.Utils.Form.MassInput.Liveliness import Data.Aeson @@ -26,37 +26,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 Data.List (iterate) import Control.Monad.Reader.Class (MonadReader(local)) -data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n) - -class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where - boxDimensions :: [BoxDimension x] - boxOrigin :: x - -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 } deriving newtype (Num, Integral, Real, Enum, PathPiece) deriving (Eq, Ord, Generic, Typeable, Read, Show) @@ -78,7 +56,7 @@ newtype ListPosition = ListPosition { unListPosition :: Natural } makeWrapped ''ListPosition instance IsBoxCoord ListPosition where - boxDimensions = [BoxDimension id] + boxDimensions = [BoxDimension _Wrapped] boxOrigin = 0 instance Liveliness ListLength where @@ -96,7 +74,42 @@ 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, ToJSONKey, FromJSONKey) + deriving (Eq, Ord, Generic, Typeable, Read, Show) + +makeWrapped ''EnumPosition + +instance (Enum enum, Bounded enum, PathPiece 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, 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 miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition) @@ -270,7 +283,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do [] -> return dimRes' ((_, BoxDimension dim) : _) -> do let - miCoords = Set.fromList . takeWhile (\c -> review (liveCoord c) sentLiveliness) $ iterate (over dim succ) miCoord + miCoords + = Set.fromList + . takeWhile (\c -> review (liveCoord c) sentLiveliness) + $ set dim <$> enumFrom (miCoord ^. dim) <*> pure miCoord dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords return $ dimRes' `Map.union` fold dimRess diff --git a/src/Handler/Utils/Form/MassInput/Liveliness.hs b/src/Handler/Utils/Form/MassInput/Liveliness.hs new file mode 100644 index 000000000..53c33d236 --- /dev/null +++ b/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 (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 => BoxDimension (Lens' x n) + +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)) + + From e4acc2653a480ef7604875376dcae6c269f5fa41 Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Thu, 18 Apr 2019 21:05:43 +0200 Subject: [PATCH 13/19] make interactive fieldsets js util work with checkboxes --- static/js/utils/form.js | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/static/js/utils/form.js b/static/js/utils/form.js index cb7cdd9f9..e7e6401aa 100644 --- a/static/js/utils/form.js +++ b/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 * *
...
*
...
@@ -135,6 +137,11 @@ *