diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 9071ab4b4..4622bdafd 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -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! diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 211199d82..c7ff11b6c 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -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 diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 5bd9eaaff..f65c811eb 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Winnie Ros +-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel -- -- 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 +
    + $forall (usr,_) <- usersNotFound +
  • #{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 - - |] - 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 +-- +-- |] +-- 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 }