From 4520c1be49098c5eb768c6162ffe0e71bff28ad8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 4 Apr 2019 15:59:45 +0200 Subject: [PATCH] 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