chore(add-users): add confirmation form
This commit is contained in:
Sarah Vaupel
parent
9850e1dd88
commit
94a96352cc
@ -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?
|
||||
|
||||
@ -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?
|
||||
|
||||
@ -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
|
||||
<li>#{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
|
||||
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} checked>
|
||||
|]
|
||||
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 }
|
||||
|
||||
|
||||
@ -74,6 +74,7 @@ data GlobalPostParam = PostFormIdentifier
|
||||
| PostBearer
|
||||
| PostDBCsvImportAction | PostDBCsvImportAvailableActions
|
||||
| PostDBCsvReImport
|
||||
| PostCourseUserAddConfirmAction | PostCourseUserAddConfirmAvailableActions
|
||||
| PostLoginDummy
|
||||
| PostExamAutoOccurrencePrevious
|
||||
| PostLanguage
|
||||
|
||||
@ -4,7 +4,7 @@ $# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
||||
$#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>_{MsgCourseAddUserConfirmationTip}
|
||||
$#<section>
|
||||
$# <p>_{MsgCourseAddUserConfirmationTip}
|
||||
<section>
|
||||
^{confirmForm}
|
||||
|
||||
@ -7,11 +7,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
#{csrf}
|
||||
^{availableActs}
|
||||
<div .actions>
|
||||
$forall actionClass <- sortOn dbtCsvCoarsenActionClass (Map.keys actionMap)
|
||||
$forall actionClass <- sortOn id (Map.keys actionMap)
|
||||
<div .action>
|
||||
<input type=checkbox id=#{actionClassIdent actionClass} .action__checkbox :defaultChecked actionClass:checked>
|
||||
<input type=checkbox id=#{actionClassIdent actionClass} .action__checkbox checked>
|
||||
<label .action__label for=#{actionClassIdent actionClass}>
|
||||
^{dbtCsvRenderActionClass actionClass}
|
||||
^{courseRegisterRenderActionClass actionClass}
|
||||
|
||||
<fieldset .action__fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{actionClassIdent actionClass}>
|
||||
<div .action__checked-counter>
|
||||
@ -22,6 +22,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<div .action__options>
|
||||
$forall action <- Set.toList (actionMap ! actionClass)
|
||||
<div .action__option>
|
||||
^{csvActionCheckBox [] action}
|
||||
^{confirmCheckBox [] action}
|
||||
<label .action__option-label for=#{actionIdent action}>
|
||||
^{dbtCsvRenderKey existing action}
|
||||
^{courseRegisterRenderAction action}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user