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

feat(add-users): correctly add users and reroute

Browse Source
This commit is contained in:
Sarah Vaupel 2022-12-12 01:16:01 +01:00
parent ee90856b50
commit fecc752d6c
3 changed files with 322 additions and 158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/courses/courses/de-de-formal.msg
View File

@ -122,6 +122,7 @@ CourseParticipantsAlreadyTutorialMember n@Int: #{n} #{pluralDE n "Teinehmer:in"
CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich angemeldet CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich angemeldet
CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Übungsgruppe angemeldet CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Übungsgruppe angemeldet
CourseParticipantsRegisterConfirmationHeading: Teilnehmer:innen hinzufügen CourseParticipantsRegisterConfirmationHeading: Teilnehmer:innen hinzufügen
CourseParticipantsRegisterUnnecessary: Alle angeforderten Anmeldungen sind bereits vorhanden. Es wurden keine Änderungen vorgenommen.
CourseApplicationText: Text-Bewerbung CourseApplicationText: Text-Bewerbung
CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung! CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung!

1
messages/uniworx/categories/courses/courses/en-eu.msg
View File

@ -115,6 +115,7 @@ CourseParticipantsRegisterTutorialField: Tutorial
CourseParticipantsRegisterTutorialFieldTip: If there is no tutorial with this name, a new one will be created. If there is a tutorial with this name, the course participants will be registered for it. CourseParticipantsRegisterTutorialFieldTip: If there is no tutorial with this name, a new one will be created. If there is a tutorial with this name, the course participants will be registered for it.
CourseParticipantsRegisterNoneGiven: No persons given to register! CourseParticipantsRegisterNoneGiven: No persons given to register!
CourseParticipantsRegisterNotFoundInAvs n: #{n} #{pluralEN n "person" "persons"} could not be found in AVS CourseParticipantsRegisterNotFoundInAvs n: #{n} #{pluralEN n "person" "persons"} could not be found in AVS
CourseParticipantsRegisterUnnecessary: All requested registrations have already been saved. No actions have been performed.
CourseParticipantsInvited n: #{n} #{pluralEN n "invitation" "invitations"} sent via email CourseParticipantsInvited n: #{n} #{pluralEN n "invitation" "invitations"} sent via email
CourseParticipantsAlreadyRegistered n: #{n} #{pluralEN n "participant is" "participants are"} already enrolled CourseParticipantsAlreadyRegistered n: #{n} #{pluralEN n "participant is" "participants are"} already enrolled

478
src/Handler/Course/ParticipantInvite.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de> -- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -13,79 +13,151 @@ import Handler.Utils.Avs
import Jobs.Queue import Jobs.Queue
--import qualified Database.Esqueleto.Legacy as E
--import qualified Data.Conduit.List as C (sourceList)
--import qualified Data.Conduit.Combinators as C
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Data.List (genericLength) --import Data.List (genericLength)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Time.Zones as TZ import qualified Data.Time.Zones as TZ
import qualified Data.Set as Set import qualified Data.Set as Set
import Control.Monad.Except (MonadError(..)) import Control.Monad.Except (MonadError(..))
--import Control.Monad.State (evalStateT)
--import Control.Monad.State.Class (modify)
--import qualified Control.Monad.State as State
import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Generics.Deriving.Monoid (memptydefault, mappenddefault)
type UserSearchKey = Text
type TutorialIdent = CI Text type TutorialIdent = CI Text
data ButtonCourseRegisterMode = BtnCourseRegisterAdd | BtnCourseRegisterConfirm | BtnCourseRegisterAbort --data ButtonCourseRegisterMode = BtnCourseRegisterAdd | BtnCourseRegisterConfirm | BtnCourseRegisterAbort
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCourseRegisterMode --instance Universe ButtonCourseRegisterMode
instance Finite ButtonCourseRegisterMode --instance Finite ButtonCourseRegisterMode
--
--embedRenderMessage ''UniWorX ''ButtonCourseRegisterMode id
--
--nullaryPathPiece ''ButtonCourseRegisterMode $ camelToPathPiece' 1
--
--instance Button UniWorX ButtonCourseRegisterMode where
-- btnLabel x = [whamlet|_{x}|]
--
-- btnClasses BtnCourseRegisterAdd = [BCIsButton, BCPrimary]
-- btnClasses BtnCourseRegisterConfirm = [BCIsButton, BCPrimary]
-- btnClasses BtnCourseRegisterAbort = [BCIsButton, BCDanger]
--
-- btnValidate _ BtnCourseRegisterAbort = False
-- btnValidate _ _ = True
--
--
--data CourseRegisterAction
-- = CourseRegisterActionAddParticipant
-- | CourseRegisterActionAddTutorialMember
-- | CourseRegisterActionUnknownPerson
-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
--instance Universe CourseRegisterAction
--instance Finite CourseRegisterAction
--
--data CourseRegisterActionData
-- = CourseRegisterActionAddParticipantData
-- { crActAddParticipantUser :: UserId
-- , crActAddParticipantTutorial :: Maybe TutorialIdent
-- }
-- | CourseRegisterActionAddTutorialMemberData
-- { crActAddTutorialMemberParticipant :: CourseParticipantId
-- , crActAddTutorialMemberTutorial :: TutorialIdent
-- }
-- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display
-- { crActUnknownPersonIdent :: Text
-- }
-- deriving (Eq, Ord, Read, Show, Generic, Typeable)
--
--makeLenses_ ''CourseRegisterActionData
--
--classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction
--classifyRegisterAction = \case
-- CourseRegisterActionAddParticipantData{} -> CourseRegisterActionAddParticipant
-- CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember
-- CourseRegisterActionUnknownPersonData{} -> CourseRegisterActionUnknownPerson
--
--data CourseRegisterActionClass
-- = CourseRegisterActionClassNew
-- | CourseRegisterActionClassExisting
-- | CourseRegisterActionClassMissing
-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
--instance Universe CourseRegisterActionClass
--instance Finite CourseRegisterActionClass
embedRenderMessage ''UniWorX ''ButtonCourseRegisterMode id --courseRegisterCoarsenActionClass :: CourseRegisterAction -> CourseRegisterActionClass
--courseRegisterCoarsenActionClass = \case
-- CourseRegisterActionAddParticipant -> CourseRegisterActionClassNew
-- CourseRegisterActionAddTutorialMember -> CourseRegisterActionClassExisting
-- CourseRegisterActionUnknownPerson -> CourseRegisterActionClassMissing
--
--data CourseRegisterActionDiff -- old new key
-- = CourseRegisterActionDiffNew
-- { crActKey :: Text
-- , crActNewUser :: UserId -- crActNewKey :: Maybe key
-- , crActNewTutorial :: Maybe TutorialIdent -- crActNew :: new
-- }
-- | CourseRegisterActionDiffExisting
-- { crActKey :: Text
-- , crActOldUser :: UserId -- crActOldKey :: key
-- , crActOldTutorial :: TutorialIdent -- crActOld :: old
-- , crActNewTutorial :: Maybe TutorialIdent -- crActNew :: new
-- }
-- | CourseRegisterActionDiffMissing
-- { crActKey :: Text
-- --{ crActOldKey :: key
-- --, crActOld :: old
-- }
--
--makeLenses_ ''CourseRegisterActionDiff
--makePrisms ''CourseRegisterActionDiff
nullaryPathPiece ''ButtonCourseRegisterMode $ camelToPathPiece' 1 --data CourseRegisterException
-- = CourseRegisterExceptionDuplicateIdent
-- { crExcptDuplicateIdent :: Text
-- }
-- | CourseRegisterException
-- { crExcpt :: Text
-- }
-- deriving (Show, Typeable)
--
--makeLenses_ ''CourseRegisterException
--
--instance Exception CourseRegisterException
instance Button UniWorX ButtonCourseRegisterMode where --courseRegisterRenderException :: CourseRegisterException -> DB Text
btnLabel x = [whamlet|_{x}|] --courseRegisterRenderException = ap getMessageRender . pure
--
btnClasses BtnCourseRegisterAdd = [BCIsButton, BCPrimary] --registerActionDefaultChecked :: CourseRegisterAction -> Bool
btnClasses BtnCourseRegisterConfirm = [BCIsButton, BCPrimary] --registerActionDefaultChecked = (/=) CourseRegisterActionUnknownPerson
btnClasses BtnCourseRegisterAbort = [BCIsButton, BCDanger] --
--registerActionDisabled :: CourseRegisterAction -> Bool
btnValidate _ BtnCourseRegisterAbort = False --registerActionDisabled = (==) CourseRegisterActionUnknownPerson
btnValidate _ _ = True
data CourseRegisterAction data AddUserRequest = AddUserRequest
= CourseRegisterActionAddParticipant { auReqUsers :: Set UserSearchKey
| CourseRegisterActionAddTutorialMember , auReqTutorial :: Maybe TutorialIdent
| CourseRegisterActionUnknownPerson
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe CourseRegisterAction
instance Finite CourseRegisterAction
data CourseRegisterActionData
= CourseRegisterActionAddParticipantData
{ crActParticipantUser :: UserId
, crActParticipantTutorial :: Maybe TutorialIdent
}
| CourseRegisterActionAddTutorialMemberData
{ crActTutorialMemberParticipant :: CourseParticipantId
, crActTutorialMemberTutorial :: TutorialIdent
}
| CourseRegisterActionUnknownPersonData -- pseudo-action; just for display
{ crActUnknownPersonIdent :: Text
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLenses_ ''CourseRegisterActionData
classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction
classifyRegisterAction = \case
CourseRegisterActionAddParticipantData{} -> CourseRegisterActionAddParticipant
CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember
CourseRegisterActionUnknownPersonData{} -> CourseRegisterActionUnknownPerson
data AddUsers = AddUsers
{ auUsers :: Set Text
, auTutorial :: Maybe TutorialIdent
} deriving (Eq, Ord, Read, Show, Generic, Typeable) } deriving (Eq, Ord, Read, Show, Generic, Typeable)
--data AddUser = AddUser
-- { addUserIdent :: Text
-- , addUserTutorial :: Maybe TutorialIdent
-- } deriving (Eq, Ord, Read, Show, Generic, Typeable)
data AddParticipantsResult = AddParticipantsResult data AddParticipantsResult = AddParticipantsResult
{ aurNotFound :: Set Text { aurNotFound :: Set UserSearchKey
, aurAlreadyRegistered , aurAlreadyRegistered
, aurAlreadyTutorialMember , aurAlreadyTutorialMember
, aurRegisterSuccess , aurRegisterSuccess
@ -106,58 +178,79 @@ postCAddUserR tid ssh csh = do
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-- mr <- getMessageRender -- mr <- getMessageRender
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
((usersToRegister :: FormResult AddUsers, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
let let
cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text)
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList) cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList)
auUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auReqUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
auTutorial <- optionalActionW auReqTutorial <- optionalActionW
( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting
( fslI MsgCourseParticipantsRegisterTutorialOption ) ( fslI MsgCourseParticipantsRegisterTutorialOption )
( Just True ) ( Just True )
return $ AddUsers <$> auUsers <*> auTutorial return $ AddUserRequest <$> auReqUsers <*> auReqTutorial
-- let dest = CourseR tid ssh csh . maybe CUsersR (flip TutorialR TUsersR . CI.mk) . join . fmap auTutorial $ formResult' usersToRegister -- let dest = CourseR tid ssh csh . maybe CUsersR (flip TutorialR TUsersR . CI.mk) . join . fmap auTutorial $ formResult' usersToRegister
let dest | Just AddUsers{auTutorial=Just tutn} <- formResult' usersToRegister --let dest | Just AddUsers{auTutorial=Just tutn} <- formResult' usersToRegister
= CTutorialR tid ssh csh tutn TUsersR -- = CTutorialR tid ssh csh tutn TUsersR
| otherwise -- | otherwise
= CourseR tid ssh csh CUsersR -- = CourseR tid ssh csh CUsersR
formResultModal usersToRegister dest $ \AddUsers{..} -> hoist runDBJobs $ do -- formResultModal usersToRegister dest $ \AddUsers{..} -> hoist runDBJobs $ do
avsUsers :: Map Text (Maybe UserId) <- sequenceA . flip Map.fromSet auUsers $ liftHandler . upsertAvsUser formResult usersToAdd $ \AddUserRequest{..} -> do
case catMaybes $ Map.elems avsUsers of avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet upsertAvsUser auReqUsers
[] -> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven let (usersFound, usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
uids -> do unless (null usersNotFound) $
registerUsers cid avsUsers let msgContent = [whamlet|
for_ auTutorial $ \tutorialName -> lift $ do $newline never
-- TODO: move somewhere else <ul>
now <- liftIO getCurrentTime $forall (usr,_) <- usersNotFound
Entity tutId _ <- upsert <li>#{usr}
Tutorial |]
{ tutorialCourse = cid in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
, tutorialType = CI.mk mempty -- TODO: remove type? unneeded? if null usersFound
, tutorialCapacity = Nothing then redirect currentRoute
, tutorialRoom = Nothing else do
, tutorialRoomHidden = False (Set.toList -> registeredUsers) <- registerUsers cid avsUsers
, tutorialTime = Occurrences mempty mempty case auReqTutorial of
, tutorialRegGroup = Nothing -- TODO: remove Nothing -> redirect $ CourseR tid ssh csh CUsersR
, tutorialRegisterFrom = Nothing Just tutorialName -> do
, tutorialRegisterTo = Nothing -- TODO: move somewhere else
, tutorialDeregisterUntil = Nothing now <- liftIO getCurrentTime
, tutorialLastChanged = now runDB $ do
, tutorialTutorControlled = False Entity tutId _ <- upsert
, .. Tutorial
} { tutorialCourse = cid
[ TutorialName =. tutorialName , tutorialType = CI.mk mempty -- TODO: remove type? unneeded?
, TutorialLastChanged =. now , tutorialCapacity = Nothing
] , tutorialRoom = Nothing
for_ uids $ \tutorialParticipantUser -> upsert , tutorialRoomHidden = False
TutorialParticipant , tutorialTime = Occurrences mempty mempty
{ tutorialParticipantTutorial = tutId , tutorialRegGroup = Nothing -- TODO: remove
, .. , tutorialRegisterFrom = Nothing
} , tutorialRegisterTo = Nothing
[] , tutorialDeregisterUntil = Nothing
-- tell . pure <=< messageI Success . MsgCourseParticipantsRegisteredTutorial $ length uids , tutorialLastChanged = now
, tutorialTutorControlled = False
, ..
}
[ TutorialName =. tutorialName
, TutorialLastChanged =. now
]
(Set.fromList -> prevParticipants) <- selectList [TutorialParticipantUser <-. registeredUsers, TutorialParticipantTutorial ==. tutId] []
(Set.fromList -> participants) <- for registeredUsers $ \tutorialParticipantUser -> upsert
TutorialParticipant
{ tutorialParticipantTutorial = tutId
, ..
}
[]
let newParticipants = participants Set.\\ prevParticipants
unless (Set.null newParticipants) $
addMessageI Success . MsgCourseParticipantsRegisteredTutorial $ Set.size newParticipants
unless (Set.null prevParticipants) $
addMessageI Info . MsgCourseParticipantsAlreadyTutorialMember $ length prevParticipants
-- tell . pure <=< messageI Success . MsgCourseParticipantsRegisteredTutorial $ length uids
redirect $ CTutorialR tid ssh csh tutorialName TUsersR
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
@ -168,79 +261,148 @@ postCAddUserR tid ssh csh = do
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
} }
--getRowKey :: AddUser -> MaybeT DB UserId
--getRowKey AddUser{..} = MaybeT . liftHandler $ upsertAvsUser addUserIdent
confirmAddUser :: Handler Html --confirmAddUser :: SomeRoute UniWorX -> Handler Html
confirmAddUser = do --confirmAddUser srcRoute = do
siteLayoutMsg MsgCourseParticipantsRegisterConfirmationHeading $ do -- let
setTitleI MsgCourseParticipantsRegisterConfirmationHeading -- existing = Map.fromList $ zip currentKeys rows
let -- sourceDiff :: ConduitT () CourseRegisterActionDiff (StateT (Map CourseRegisterActionClass CourseRegisterActionData) DB) ()
confirmCheckBox :: Widget -- sourceDiff = do
confirmCheckBox = do -- let
let sJsonField :: Field (HandlerFor UniWorX) a -- toDiff :: CourseRegisterActionData -> StateT (Map CourseRegisterActionClass CourseRegisterActionData) DB CourseRegisterActionDiff
sJsonField = secretJsonField' $ \theId name attrs val _isReq -> -- toDiff row = do
[whamlet| -- rowKey <- lift $ handle (throwM . (CourseRegisterException :: Text -> CourseRegisterException) <=< courseRegisterRenderException) . runMaybeT $ getRowKey row
$newline never -- seenKeys <- State.get
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} checked> -- (<* modify (maybe id (flip Map.insert row) rowKey)) $ if
|] -- | Just rowKey' <- rowKey
fieldView sJsonField act mempty vAttrs (Right act) False -- , Just oldRow <- Map.lookup rowKey' seenKeys
availableActs :: Widget -- -> throwM $ CourseRegisterExceptionDuplicateIdent rowKey'
availableActs = fieldView (secretJsonField :: Field Handler (Set csvAction)) "" mempty [] (Right . Set.empty) False -- | Just rowKey' <- rowKey
(confirmForm', confirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCourseRegisterConfirm, BtnCourseRegisterAbort] . identifyForm FIDCourseRegisterConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "course/add-user/confirmation")) -- , Just oldRow <- Map.lookup rowKey' existing
let confirmForm = wrapForm confirmForm' FormSettings -- -> return $ CourseRegisterActionDiffExisting rowKey' oldRow row
{ formMethod = POST -- | otherwise
, formAction = Just $ tblLink id -- -> return $ CourseRegisterActionDiffNew rowKey' oldRow row
, formEncoding = confirmEnctype -- transPipe liftHandler blubb .| C.mapM toDiff
, formAttrs = [] -- seen <- State.get
, formSubmit = FormNoSubmit -- forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if
, formAnchor = Nothing :: Maybe Text -- | Map.member rowKey seen -> return ()
} -- | otherwise -> yield $ CourseRegisterActionDiffMissing rowKey
$(widgetFile "course/add-user/confirmation-wrapper") --
-- accActionMap :: Map CourseRegisterActionClass (Set CourseRegisterActionData) -> CourseRegisterActionData -> Map CourseRegisterActionClass (Set CourseRegisterActionData)
-- accActionMap acc act = Map.insertWith Set.union (courseRegisterCoarsenActionClass $ classifyRegisterAction act) (Set.singleton act) acc
--
-- courseRegisterComputeActions :: CourseRegisterActionDiff -> ConduitT () CourseRegisterActionData DB ()
-- courseRegisterComputeActions = \case
-- CourseRegisterActionDiffNew{..} -> return () -- crActKey, crActNewUser, crActNewTutorial
-- -- TODO: fetch course participant, if any
-- -- TODO: if course participant was found, fetch tutorial member and (if yes) yield CourseRegisterActionAddTutorialMemberData
-- -- TODO: if no course participant was found, yield CourseRegisterActionAddParticipantData
-- CourseRegisterActionDiffExisting{..} -> return () -- TODO
-- CourseRegisterActionDiffMissing{} -> return () -- pseudo-action; no deletion -- TODO: yield smth?
-- courseRegisterComputeActions' :: ConduitT CourseRegisterActionDiff Void DB (Map CourseRegisterActionClass (Set CourseRegisterActionData))
-- courseRegisterComputeActions' = do
-- let innerAct = awaitForever $ \x
-- -> let doHandle = handle $ throwM CourseRegisterException <=< courseRegisterRenderException
-- in C.sourceList <=< lift . doHandle . runConduit $ courseRegisterComputeActions x .| C.foldMap pure
-- innerAct .| C.foldl accActionMap Map.empty
-- actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift courseRegisterComputeActions'
--
-- when (Map.null actionMap) $
-- addMessageI Info MsgCourseParticipantsRegisterUnnecessary
-- redirect srcRoute
--
-- E.transactionSave -- Commit side-effects of courseRegisterComputeActions
--
-- liftHandler . (>>= sendResponse) $
-- siteLayoutMsg MsgCourseParticipantsRegisterConfirmationHeading $ do
-- setTitleI MsgCourseParticipantsRegisterConfirmationHeading
-- let precomputeIdents :: forall f m. (Eq (Element f), MonoFoldable f, MonadHandler m) => f -> m (Element f -> Text)
-- precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed")
-- actionClassIdent <- precomputeIdents $ Map.keys actionMap
-- actionIdent <- precomputeIdents . Set.union $ Map.elems actionMap
-- let
-- --defaultChecked actClass = case courseRegisterCoarsenActionClass actClass of
-- -- CourseRegisterActionDiffMissing -> False
-- -- _other -> True
-- defaultChecked = const True
-- confirmCheckBox :: [(Text,Text)] -> CourseRegisterActionData -> Widget
-- confirmCheckBox vAttrs act = do
-- let sJsonField :: Field (HandlerFor UniWorX) CourseRegisterAction
-- sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
-- [whamlet|
-- $newline never
-- <input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} :registerActionDefaultChecked (classifyRegisterAction act):checked :registerActionDisabled (classifyRegisterAction act):disabled>
-- |]
-- fieldView sJsonField act mempty vAttrs (Right act) False
-- availableActs :: Widget
-- availableActs = fieldView (secretJsonField :: Field Handler (Set CourseRegisterAction)) "" mempty [] (Right . Set.unions $ Map.elems actionMap) False
-- (confirmForm', confirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCourseRegisterConfirm, BtnCourseRegisterAbort] . identifyForm FIDCourseRegisterConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "course/add-user/confirmation"))
-- let confirmForm = wrapForm confirmForm' FormSettings
-- { formMethod = POST
-- , formAction = Just $ tblLink id
-- , formEncoding = confirmEnctype
-- , formAttrs = []
-- , formSubmit = FormNoSubmit
-- , formAnchor = Nothing :: Maybe Text
-- }
-- $(widgetFile "course/add-user/confirmation-wrapper")
registerUsers :: CourseId -> Map Text (Maybe UserId) -> WriterT [Message] (YesodJobDB UniWorX) () registerUsers :: CourseId -> Map UserSearchKey (Maybe UserId) -> Handler (Set UserId) -- WriterT [Message] (YesodJobDB UniWorX) ()
registerUsers cid users registerUsers cid users
| null users = tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven | Map.null users = do
| otherwise = tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT . mapM_ (registerUser cid) $ Map.toList users addMessageI Error MsgCourseParticipantsRegisterNoneGiven
return Set.empty
| otherwise = do
(mconcat -> AddParticipantsResult{..}) <- runDBJobs . mapM (registerUser cid) $ Map.toList users
unless (Set.null aurRegisterSuccess) $
addMessageI Success . MsgCourseParticipantsRegistered $ Set.size aurRegisterSuccess
unless (Set.null aurAlreadyRegistered) $
addMessageI Info . MsgCourseParticipantsAlreadyRegistered $ Set.size aurAlreadyRegistered
return $ aurRegisterSuccess `Set.union` aurAlreadyRegistered
addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) --addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> AddParticipantsResult -- => AddParticipantsResult
-> ReaderT (YesodPersistBackend UniWorX) m [Message] -- -> ReaderT (YesodPersistBackend UniWorX) m [Message]
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do --addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
unless (null aurNotFound) $ do -- unless (null aurNotFound) $ do
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisterNotFoundInAvs (length aurNotFound)}|] -- let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisterNotFoundInAvs (length aurNotFound)}|]
modalContent = $(widgetFile "messages/courseInvitationNotFoundInAvs") -- modalContent = $(widgetFile "messages/courseInvitationNotFoundInAvs")
tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent) -- tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
--
aurAlreadyRegistered' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyRegistered) -- aurAlreadyRegistered' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyRegistered)
aurAlreadyTutorialMember' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyTutorialMember) -- aurAlreadyTutorialMember' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyTutorialMember)
--
unless (null aurAlreadyRegistered) $ do -- unless (null aurAlreadyRegistered) $ do
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] -- let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") -- modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) -- tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
unless (null aurAlreadyTutorialMember) $ do -- unless (null aurAlreadyTutorialMember) $ do
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyTutorialMember (length aurAlreadyTutorialMember)}|] -- let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyTutorialMember (length aurAlreadyTutorialMember)}|]
modalContent = $(widgetFile "messages/courseInvitationAlreadyTutorialMember") -- modalContent = $(widgetFile "messages/courseInvitationAlreadyTutorialMember")
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) -- tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
--
unless (null aurRegisterSuccess) $ -- unless (null aurRegisterSuccess) $
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess -- tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess
unless (null aurTutorialSuccess) $ -- unless (null aurTutorialSuccess) $
tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess -- tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess
registerUser :: CourseId registerUser :: CourseId
-> (Text, Maybe UserId) -> (UserSearchKey, Maybe UserId)
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) () -> YesodJobDB UniWorX AddParticipantsResult
registerUser _cid ( avsIdent, Nothing ) = tell $ mempty { aurNotFound = Set.singleton avsIdent } -- -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
registerUser cid (_avsIdent, Just uid) = exceptT tell tell $ do registerUser _cid ( avsIdent, Nothing ) = return $ mempty { aurNotFound = Set.singleton avsIdent } -- tell $ mempty { aurNotFound = Set.singleton avsIdent }
whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $ registerUser cid (_avsIdent, Just uid) = exceptT return return $ do
whenM (lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid } throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
courseParticipantRegistration <- liftIO getCurrentTime courseParticipantRegistration <- liftIO getCurrentTime
void . lift . lift $ upsert void . lift $ upsert
CourseParticipant CourseParticipant -- TODO: use participantId instead of userId for aurRegisterSuccess
{ courseParticipantCourse = cid { courseParticipantCourse = cid
, courseParticipantUser = uid , courseParticipantUser = uid
, courseParticipantAllocated = Nothing , courseParticipantAllocated = Nothing
@ -251,7 +413,7 @@ registerUser cid (_avsIdent, Just uid) = exceptT tell tell $ do
, CourseParticipantAllocated =. Nothing , CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive , CourseParticipantState =. CourseParticipantActive
] ]
lift . lift . audit $ TransactionCourseParticipantEdit cid uid lift . audit $ TransactionCourseParticipantEdit cid uid
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all? lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all?
return $ mempty { aurRegisterSuccess = Set.singleton uid } return $ mempty { aurRegisterSuccess = Set.singleton uid }