feat(add-users): correctly add users and reroute
This commit is contained in:
Sarah Vaupel
parent
ee90856b50
commit
fecc752d6c
@ -122,6 +122,7 @@ CourseParticipantsAlreadyTutorialMember n@Int: #{n} #{pluralDE n "Teinehmer:in"
|
||||
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
|
||||
CourseParticipantsRegisterConfirmationHeading: Teilnehmer:innen hinzufügen
|
||||
CourseParticipantsRegisterUnnecessary: Alle angeforderten Anmeldungen sind bereits vorhanden. Es wurden keine Änderungen vorgenommen.
|
||||
|
||||
CourseApplicationText: Text-Bewerbung
|
||||
CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung!
|
||||
|
||||
@ -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.
|
||||
CourseParticipantsRegisterNoneGiven: No persons given to register!
|
||||
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
|
||||
CourseParticipantsAlreadyRegistered n: #{n} #{pluralEN n "participant is" "participants are"} already enrolled
|
||||
|
||||
@ -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
|
||||
|
||||
@ -13,79 +13,151 @@ import Handler.Utils.Avs
|
||||
|
||||
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 Data.List (genericLength)
|
||||
--import Data.List (genericLength)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Time.Zones as TZ
|
||||
import qualified Data.Set as Set
|
||||
|
||||
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)
|
||||
|
||||
|
||||
type UserSearchKey = Text
|
||||
type TutorialIdent = CI Text
|
||||
|
||||
|
||||
data ButtonCourseRegisterMode = BtnCourseRegisterAdd | BtnCourseRegisterConfirm | BtnCourseRegisterAbort
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonCourseRegisterMode
|
||||
instance Finite ButtonCourseRegisterMode
|
||||
--data ButtonCourseRegisterMode = BtnCourseRegisterAdd | BtnCourseRegisterConfirm | BtnCourseRegisterAbort
|
||||
-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
--instance Universe 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
|
||||
btnLabel x = [whamlet|_{x}|]
|
||||
|
||||
btnClasses BtnCourseRegisterAdd = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnCourseRegisterConfirm = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnCourseRegisterAbort = [BCIsButton, BCDanger]
|
||||
|
||||
btnValidate _ BtnCourseRegisterAbort = False
|
||||
btnValidate _ _ = True
|
||||
--courseRegisterRenderException :: CourseRegisterException -> DB Text
|
||||
--courseRegisterRenderException = ap getMessageRender . pure
|
||||
--
|
||||
--registerActionDefaultChecked :: CourseRegisterAction -> Bool
|
||||
--registerActionDefaultChecked = (/=) CourseRegisterActionUnknownPerson
|
||||
--
|
||||
--registerActionDisabled :: CourseRegisterAction -> Bool
|
||||
--registerActionDisabled = (==) CourseRegisterActionUnknownPerson
|
||||
|
||||
|
||||
data CourseRegisterAction
|
||||
= CourseRegisterActionAddParticipant
|
||||
| CourseRegisterActionAddTutorialMember
|
||||
| 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
|
||||
data AddUserRequest = AddUserRequest
|
||||
{ auReqUsers :: Set UserSearchKey
|
||||
, auReqTutorial :: Maybe TutorialIdent
|
||||
} 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
|
||||
{ aurNotFound :: Set Text
|
||||
{ aurNotFound :: Set UserSearchKey
|
||||
, aurAlreadyRegistered
|
||||
, aurAlreadyTutorialMember
|
||||
, aurRegisterSuccess
|
||||
@ -106,58 +178,79 @@ postCAddUserR tid ssh csh = do
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
-- mr <- getMessageRender
|
||||
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
|
||||
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)
|
||||
auUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
|
||||
auTutorial <- optionalActionW
|
||||
auReqUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
|
||||
auReqTutorial <- optionalActionW
|
||||
( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting
|
||||
( fslI MsgCourseParticipantsRegisterTutorialOption )
|
||||
( 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 | Just AddUsers{auTutorial=Just tutn} <- formResult' usersToRegister
|
||||
= CTutorialR tid ssh csh tutn TUsersR
|
||||
| otherwise
|
||||
= CourseR tid ssh csh CUsersR
|
||||
formResultModal usersToRegister dest $ \AddUsers{..} -> hoist runDBJobs $ do
|
||||
avsUsers :: Map Text (Maybe UserId) <- sequenceA . flip Map.fromSet auUsers $ liftHandler . upsertAvsUser
|
||||
case catMaybes $ Map.elems avsUsers of
|
||||
[] -> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
|
||||
uids -> do
|
||||
registerUsers cid avsUsers
|
||||
for_ auTutorial $ \tutorialName -> lift $ do
|
||||
-- TODO: move somewhere else
|
||||
now <- liftIO getCurrentTime
|
||||
Entity tutId _ <- upsert
|
||||
Tutorial
|
||||
{ tutorialCourse = cid
|
||||
, tutorialType = CI.mk mempty -- TODO: remove type? unneeded?
|
||||
, tutorialCapacity = Nothing
|
||||
, tutorialRoom = Nothing
|
||||
, tutorialRoomHidden = False
|
||||
, tutorialTime = Occurrences mempty mempty
|
||||
, tutorialRegGroup = Nothing -- TODO: remove
|
||||
, tutorialRegisterFrom = Nothing
|
||||
, tutorialRegisterTo = Nothing
|
||||
, tutorialDeregisterUntil = Nothing
|
||||
, tutorialLastChanged = now
|
||||
, tutorialTutorControlled = False
|
||||
, ..
|
||||
}
|
||||
[ TutorialName =. tutorialName
|
||||
, TutorialLastChanged =. now
|
||||
]
|
||||
for_ uids $ \tutorialParticipantUser -> upsert
|
||||
TutorialParticipant
|
||||
{ tutorialParticipantTutorial = tutId
|
||||
, ..
|
||||
}
|
||||
[]
|
||||
-- tell . pure <=< messageI Success . MsgCourseParticipantsRegisteredTutorial $ length uids
|
||||
--let dest | Just AddUsers{auTutorial=Just tutn} <- formResult' usersToRegister
|
||||
-- = CTutorialR tid ssh csh tutn TUsersR
|
||||
-- | otherwise
|
||||
-- = CourseR tid ssh csh CUsersR
|
||||
-- formResultModal usersToRegister dest $ \AddUsers{..} -> hoist runDBJobs $ do
|
||||
formResult usersToAdd $ \AddUserRequest{..} -> do
|
||||
avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet upsertAvsUser auReqUsers
|
||||
let (usersFound, usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
|
||||
unless (null usersNotFound) $
|
||||
let msgContent = [whamlet|
|
||||
$newline never
|
||||
<ul>
|
||||
$forall (usr,_) <- usersNotFound
|
||||
<li>#{usr}
|
||||
|]
|
||||
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
|
||||
if null usersFound
|
||||
then redirect currentRoute
|
||||
else do
|
||||
(Set.toList -> registeredUsers) <- registerUsers cid avsUsers
|
||||
case auReqTutorial of
|
||||
Nothing -> redirect $ CourseR tid ssh csh CUsersR
|
||||
Just tutorialName -> do
|
||||
-- TODO: move somewhere else
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ do
|
||||
Entity tutId _ <- upsert
|
||||
Tutorial
|
||||
{ tutorialCourse = cid
|
||||
, tutorialType = CI.mk mempty -- TODO: remove type? unneeded?
|
||||
, tutorialCapacity = Nothing
|
||||
, tutorialRoom = Nothing
|
||||
, tutorialRoomHidden = False
|
||||
, tutorialTime = Occurrences mempty mempty
|
||||
, tutorialRegGroup = Nothing -- TODO: remove
|
||||
, tutorialRegisterFrom = Nothing
|
||||
, tutorialRegisterTo = Nothing
|
||||
, tutorialDeregisterUntil = Nothing
|
||||
, 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
|
||||
|
||||
@ -168,79 +261,148 @@ postCAddUserR tid ssh csh = do
|
||||
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
|
||||
}
|
||||
|
||||
--getRowKey :: AddUser -> MaybeT DB UserId
|
||||
--getRowKey AddUser{..} = MaybeT . liftHandler $ upsertAvsUser addUserIdent
|
||||
|
||||
confirmAddUser :: Handler Html
|
||||
confirmAddUser = do
|
||||
siteLayoutMsg MsgCourseParticipantsRegisterConfirmationHeading $ do
|
||||
setTitleI MsgCourseParticipantsRegisterConfirmationHeading
|
||||
let
|
||||
confirmCheckBox :: Widget
|
||||
confirmCheckBox = do
|
||||
let sJsonField :: Field (HandlerFor UniWorX) a
|
||||
sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} checked>
|
||||
|]
|
||||
fieldView sJsonField act mempty vAttrs (Right act) False
|
||||
availableActs :: Widget
|
||||
availableActs = fieldView (secretJsonField :: Field Handler (Set csvAction)) "" mempty [] (Right . Set.empty) 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")
|
||||
--confirmAddUser :: SomeRoute UniWorX -> Handler Html
|
||||
--confirmAddUser srcRoute = do
|
||||
-- let
|
||||
-- existing = Map.fromList $ zip currentKeys rows
|
||||
-- sourceDiff :: ConduitT () CourseRegisterActionDiff (StateT (Map CourseRegisterActionClass CourseRegisterActionData) DB) ()
|
||||
-- sourceDiff = do
|
||||
-- let
|
||||
-- toDiff :: CourseRegisterActionData -> StateT (Map CourseRegisterActionClass CourseRegisterActionData) DB CourseRegisterActionDiff
|
||||
-- toDiff row = do
|
||||
-- rowKey <- lift $ handle (throwM . (CourseRegisterException :: Text -> CourseRegisterException) <=< courseRegisterRenderException) . runMaybeT $ getRowKey row
|
||||
-- seenKeys <- State.get
|
||||
-- (<* modify (maybe id (flip Map.insert row) rowKey)) $ if
|
||||
-- | Just rowKey' <- rowKey
|
||||
-- , Just oldRow <- Map.lookup rowKey' seenKeys
|
||||
-- -> throwM $ CourseRegisterExceptionDuplicateIdent rowKey'
|
||||
-- | Just rowKey' <- rowKey
|
||||
-- , Just oldRow <- Map.lookup rowKey' existing
|
||||
-- -> return $ CourseRegisterActionDiffExisting rowKey' oldRow row
|
||||
-- | otherwise
|
||||
-- -> return $ CourseRegisterActionDiffNew rowKey' oldRow row
|
||||
-- transPipe liftHandler blubb .| C.mapM toDiff
|
||||
-- seen <- State.get
|
||||
-- forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if
|
||||
-- | Map.member rowKey seen -> return ()
|
||||
-- | otherwise -> yield $ CourseRegisterActionDiffMissing rowKey
|
||||
--
|
||||
-- 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
|
||||
| null users = tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
|
||||
| otherwise = tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT . mapM_ (registerUser cid) $ Map.toList users
|
||||
| Map.null users = do
|
||||
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)
|
||||
=> AddParticipantsResult
|
||||
-> ReaderT (YesodPersistBackend UniWorX) m [Message]
|
||||
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
|
||||
unless (null aurNotFound) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisterNotFoundInAvs (length aurNotFound)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationNotFoundInAvs")
|
||||
tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
aurAlreadyRegistered' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyRegistered)
|
||||
aurAlreadyTutorialMember' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyTutorialMember)
|
||||
|
||||
unless (null aurAlreadyRegistered) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
||||
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
unless (null aurAlreadyTutorialMember) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyTutorialMember (length aurAlreadyTutorialMember)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationAlreadyTutorialMember")
|
||||
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
unless (null aurRegisterSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess
|
||||
unless (null aurTutorialSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess
|
||||
--addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
-- => AddParticipantsResult
|
||||
-- -> ReaderT (YesodPersistBackend UniWorX) m [Message]
|
||||
--addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
|
||||
-- unless (null aurNotFound) $ do
|
||||
-- let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisterNotFoundInAvs (length aurNotFound)}|]
|
||||
-- modalContent = $(widgetFile "messages/courseInvitationNotFoundInAvs")
|
||||
-- tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
|
||||
--
|
||||
-- aurAlreadyRegistered' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyRegistered)
|
||||
-- aurAlreadyTutorialMember' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyTutorialMember)
|
||||
--
|
||||
-- unless (null aurAlreadyRegistered) $ do
|
||||
-- let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
||||
-- modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
||||
-- tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
-- unless (null aurAlreadyTutorialMember) $ do
|
||||
-- let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyTutorialMember (length aurAlreadyTutorialMember)}|]
|
||||
-- modalContent = $(widgetFile "messages/courseInvitationAlreadyTutorialMember")
|
||||
-- tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
--
|
||||
-- unless (null aurRegisterSuccess) $
|
||||
-- tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess
|
||||
-- unless (null aurTutorialSuccess) $
|
||||
-- tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess
|
||||
|
||||
|
||||
registerUser :: CourseId
|
||||
-> (Text, Maybe UserId)
|
||||
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
|
||||
registerUser _cid ( avsIdent, Nothing ) = tell $ mempty { aurNotFound = Set.singleton avsIdent }
|
||||
registerUser cid (_avsIdent, Just uid) = exceptT tell tell $ do
|
||||
whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
|
||||
-> (UserSearchKey, Maybe UserId)
|
||||
-> YesodJobDB UniWorX AddParticipantsResult
|
||||
-- -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
|
||||
registerUser _cid ( avsIdent, Nothing ) = return $ mempty { aurNotFound = Set.singleton avsIdent } -- tell $ mempty { aurNotFound = Set.singleton avsIdent }
|
||||
registerUser cid (_avsIdent, Just uid) = exceptT return return $ do
|
||||
whenM (lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
|
||||
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
|
||||
|
||||
courseParticipantRegistration <- liftIO getCurrentTime
|
||||
void . lift . lift $ upsert
|
||||
CourseParticipant
|
||||
void . lift $ upsert
|
||||
CourseParticipant -- TODO: use participantId instead of userId for aurRegisterSuccess
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantAllocated = Nothing
|
||||
@ -251,7 +413,7 @@ registerUser cid (_avsIdent, Just uid) = exceptT tell tell $ do
|
||||
, CourseParticipantAllocated =. Nothing
|
||||
, CourseParticipantState =. CourseParticipantActive
|
||||
]
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all?
|
||||
lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all?
|
||||
|
||||
return $ mempty { aurRegisterSuccess = Set.singleton uid }
|
||||
|
||||
Loading…
Reference in New Issue
Block a user