diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index d85781e83..27406536e 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -108,6 +108,8 @@ CourseParticipantEnlistDirectly: Bekannte Nutzer:innen sofort als Teilnehmer:in CourseSubmissionGroup: Feste Abgabegruppe SubmissionGroupEmptyIsUnsetTip: Leer lassen um Benutzer:innen aus den jeweiligen Abgabegruppen ersatzlos zu entfernen CourseParticipantsRegisterHeading: Kursteilnehmer:innen hinzufügen +CourseParticipantsRegisterActionAddParticipants: Personen zum Kurs anmelden +CourseParticipantsRegisterActionAddTutorialMembers: Personen zu Kurs und Übungsgruppe anmelden CourseParticipantsRegisterUsersField: Zum Kurs anzumeldende Personen CourseParticipantsRegisterUsersFieldTip: Bitte Personalnummer angeben. Mehrere Personen bitte mit Komma getrennt angeben. CourseParticipantsRegisterTutorialOption: Kursteilnehmer:innen zu Übungsgruppe anmelden? diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 53d0e1193..6b8b0f257 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -108,6 +108,8 @@ CourseParticipantEnlistDirectly: Enrol known users directly CourseSubmissionGroup: Registered submission group SubmissionGroupEmptyIsUnsetTip: Leave empty to remove users from their respective submission groups CourseParticipantsRegisterHeading: Add course participants +CourseParticipantsRegisterActionAddParticipants: Add course participants +CourseParticipantsRegisterActionAddTutorialMembers: Add course and tutorial participants CourseParticipantsRegisterUsersField: Persons to register for course CourseParticipantsRegisterUsersFieldTip: Please enter personal number. Please separate multiple entries with commas. CourseParticipantsRegisterTutorialOption: Register course participants for tutorial? diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index f668b7015..25b3031d7 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -18,8 +18,10 @@ import Jobs.Queue --import qualified Data.Conduit.List as C (sourceList) --import qualified Data.Conduit.Combinators as C +import qualified Data.Aeson as Aeson import qualified Data.CaseInsensitive as CI --import Data.List (genericLength) +import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.Time.Zones as TZ @@ -37,56 +39,74 @@ 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 --- ---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 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 + { crActAddParticipantIdent :: UserSearchKey + , crActAddParticipantUser :: UserId + } + | CourseRegisterActionAddTutorialMemberData + { crActAddTutorialMemberIdent :: UserSearchKey + , crActAddTutorialMemberUser :: UserId + , crActAddTutorialMemberTutorial :: TutorialIdent + } +-- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display +-- { crActUnknownPersonIdent :: Text +-- } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +makeLenses_ ''CourseRegisterActionData + +instance Aeson.FromJSON CourseRegisterActionData where + parseJSON = Aeson.genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } + +instance Aeson.ToJSON CourseRegisterActionData where + toJSON = Aeson.genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } + toEncoding = Aeson.genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } + +_classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction +_classifyRegisterAction = \case + CourseRegisterActionAddParticipantData{} -> CourseRegisterActionAddParticipant + CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember +--CourseRegisterActionUnknownPersonData{} -> CourseRegisterActionUnknownPerson + +courseRegisterRenderActionClass :: CourseRegisterAction -> Widget +courseRegisterRenderActionClass = \case + CourseRegisterActionAddParticipant -> [whamlet|_{MsgCourseParticipantsRegisterActionAddParticipants}|] + CourseRegisterActionAddTutorialMember -> [whamlet|_{MsgCourseParticipantsRegisterActionAddTutorialMembers}|] + +courseRegisterRenderAction :: CourseRegisterActionData -> Widget +courseRegisterRenderAction = \case + CourseRegisterActionAddParticipantData{..} -> [whamlet|TODO USER (#{crActAddParticipantIdent})|] + CourseRegisterActionAddTutorialMemberData{..} -> [whamlet|TODO USER (#{crActAddTutorialMemberIdent})|] + --data CourseRegisterActionClass -- = CourseRegisterActionClassNew -- | CourseRegisterActionClassExisting @@ -175,7 +195,7 @@ instance Monoid AddParticipantsResult where getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR postCAddUserR tid ssh csh = do - cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + _cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute @@ -201,16 +221,58 @@ postCAddUserR tid ssh csh = do
  • #{usr} |] in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) - if null usersFound - then redirect currentRoute - else do - registeredUsers <- registerUsers cid avsUsers - case auReqTutorial of - Nothing -> redirect $ CourseR tid ssh csh CUsersR - Just tutorialName -> do - tutId <- upsertNewTutorial cid tutorialName - registerTutorialMembers tutId registeredUsers - redirect $ CTutorialR tid ssh csh tutorialName TUsersR + when (null usersFound) $ + redirect currentRoute + + liftHandler . (>>= sendResponse) $ + siteLayoutMsg MsgCourseParticipantsRegisterHeading $ do + setTitleI MsgCourseParticipantsRegisterHeading + + actionMap :: Map CourseRegisterAction (Set CourseRegisterActionData) <- fmap Map.unions . forM usersFound $ \case + (_, Nothing) -> error "Found user in AVS, but response is Nothing!" -- this should not be possible + (ukey, Just uid) -> do + -- isParticipant <- exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive] + case auReqTutorial of + Nothing -> return . Map.singleton CourseRegisterActionAddParticipant . Set.singleton $ CourseRegisterActionAddParticipantData ukey uid + Just crActAddTutorialMemberTutorial -> return . Map.singleton CourseRegisterActionAddTutorialMember . Set.singleton $ CourseRegisterActionAddTutorialMemberData ukey uid crActAddTutorialMemberTutorial + + 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.unions $ Map.elems actionMap + + let + confirmCheckBox :: [(Text,Text)] -> CourseRegisterActionData -> Widget + confirmCheckBox vAttrs act = do + let + sJsonField :: Field (HandlerFor UniWorX) CourseRegisterActionData + sJsonField = secretJsonField' $ \theId name attrs val _isReq -> + [whamlet| + $newline never + + |] + fieldView sJsonField (actionIdent act) (toPathPiece PostCourseUserAddConfirmAction) vAttrs (Right act) False + availableActs :: Widget + availableActs = fieldView (secretJsonField :: Field Handler (Set CourseRegisterActionData)) "" (toPathPiece PostCourseUserAddConfirmAvailableActions) [] (Right . Set.unions $ Map.elems actionMap) False + (confirmForm', confirmEnctype) <- 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 . SomeRoute $ CourseR tid ssh csh CAddUserR + , formEncoding = confirmEnctype + , formAttrs = [] + , formSubmit = FormNoSubmit + , formAnchor = Nothing :: Maybe Text + } + $(widgetFile "course/add-user/confirmation-wrapper") + + --registeredUsers <- registerUsers cid avsUsers + --case auReqTutorial of + -- Nothing -> redirect $ CourseR tid ssh csh CUsersR + -- Just tutorialName -> do + -- tutId <- upsertNewTutorial cid tutorialName + -- registerTutorialMembers tutId registeredUsers + -- redirect $ CTutorialR tid ssh csh tutorialName TUsersR let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading @@ -310,21 +372,21 @@ postCAddUserR tid ssh csh = do -- $(widgetFile "course/add-user/confirmation-wrapper") -registerUsers :: CourseId -> Map UserSearchKey (Maybe UserId) -> Handler (Set UserId) -- WriterT [Message] (YesodJobDB UniWorX) () -registerUsers cid users +_registerUsers :: CourseId -> Map UserSearchKey (Maybe UserId) -> Handler (Set UserId) -- WriterT [Message] (YesodJobDB UniWorX) () +_registerUsers cid users | Map.null users = do addMessageI Error MsgCourseParticipantsRegisterNoneGiven return Set.empty | otherwise = do - (mconcat -> AddParticipantsResult{..}) <- runDBJobs . mapM (registerUser cid) $ Map.toList users + (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 -upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId -upsertNewTutorial cid tutorialName = do +_upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId +_upsertNewTutorial cid tutorialName = do now <- liftIO getCurrentTime Entity tutId _ <- runDB $ upsert Tutorial @@ -347,8 +409,8 @@ upsertNewTutorial cid tutorialName = do ] return tutId -registerTutorialMembers :: TutorialId -> Set UserId -> Handler () -registerTutorialMembers tutId (Set.toList -> users) = runDB $ do +_registerTutorialMembers :: TutorialId -> Set UserId -> Handler () +_registerTutorialMembers tutId (Set.toList -> users) = runDB $ do prevParticipants <- fmap Set.fromList $ selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] [] participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> upsert TutorialParticipant @@ -389,12 +451,12 @@ registerTutorialMembers tutId (Set.toList -> users) = runDB $ do -- tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess -registerUser :: CourseId +_registerUser :: CourseId -> (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 +_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 } diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index 6609ed08b..39242520b 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -74,6 +74,7 @@ data GlobalPostParam = PostFormIdentifier | PostBearer | PostDBCsvImportAction | PostDBCsvImportAvailableActions | PostDBCsvReImport + | PostCourseUserAddConfirmAction | PostCourseUserAddConfirmAvailableActions | PostLoginDummy | PostExamAutoOccurrencePrevious | PostLanguage diff --git a/templates/course/add-user/confirmation-wrapper.hamlet b/templates/course/add-user/confirmation-wrapper.hamlet index 631eb1a99..bba322ce0 100644 --- a/templates/course/add-user/confirmation-wrapper.hamlet +++ b/templates/course/add-user/confirmation-wrapper.hamlet @@ -4,7 +4,7 @@ $# SPDX-FileCopyrightText: 2022 Sarah Vaupel $# $# SPDX-License-Identifier: AGPL-3.0-or-later -
    -

    _{MsgCourseAddUserConfirmationTip} +$#

    +$#

    _{MsgCourseAddUserConfirmationTip}

    ^{confirmForm} diff --git a/templates/course/add-user/confirmation.hamlet b/templates/course/add-user/confirmation.hamlet index 7c3fc225d..c25de5975 100644 --- a/templates/course/add-user/confirmation.hamlet +++ b/templates/course/add-user/confirmation.hamlet @@ -7,11 +7,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{csrf} ^{availableActs}
    - $forall actionClass <- sortOn dbtCsvCoarsenActionClass (Map.keys actionMap) + $forall actionClass <- sortOn id (Map.keys actionMap)
    - +