fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

communication prototype

Browse Source
This commit is contained in:
Steffen Jost 2019-04-16 15:03:37 +02:00
parent 23029abec6
commit dd1cd6650f
7 changed files with 89 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
messages/uniworx/de.msg
View File

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

5
src/Foundation.hs
View File

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

2
src/Handler/Corrections.hs
View File

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

33
src/Handler/Course.hs
View File

@ -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
)
]
}

2
src/Handler/Help.hs
View File

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

2
src/Handler/SystemMessage.hs
View File

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

60
src/Handler/Utils/Communication.hs
View File

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