fix(add-users): fix and refactor confirm post param handling
This commit is contained in:
Sarah Vaupel
parent
56a23b7abf
commit
727d78cabc
@ -125,6 +125,7 @@ CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer
|
||||
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.
|
||||
CourseParticipantsRegisterConfirmInvalid: Ungültiges Bestätigungsformular!
|
||||
|
||||
CourseApplicationText: Text-Bewerbung
|
||||
CourseApplicationFollowInstructions: Beachten Sie die Anweisungen zur Bewerbung!
|
||||
|
||||
@ -125,6 +125,7 @@ CourseParticipantsAlreadyTutorialMember n: #{n} #{pluralEN n "participant is" "p
|
||||
CourseParticipantsRegistered n: Successfully registered #{n} #{pluralEN n "participant" "participants"} for course
|
||||
CourseParticipantsRegisteredTutorial n: Successfully registered #{n} #{pluralEN n "participant" "participants"} for tutorial
|
||||
CourseParticipantsRegisterConfirmationHeading: Register participants
|
||||
CourseParticipantsRegisterConfirmInvalid: Invalid confirmation form!
|
||||
|
||||
CourseApplicationText: Application text
|
||||
CourseApplicationFollowInstructions: Please follow the instructions for applications!
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -30,7 +30,7 @@ type UserSearchKey = Text
|
||||
type TutorialIdent = CI Text
|
||||
|
||||
|
||||
data ButtonCourseRegisterMode = BtnCourseRegisterAdd | BtnCourseRegisterConfirm | BtnCourseRegisterAbort
|
||||
data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonCourseRegisterMode
|
||||
instance Finite ButtonCourseRegisterMode
|
||||
@ -41,11 +41,8 @@ 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
|
||||
|
||||
@ -125,30 +122,35 @@ getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler
|
||||
getCAddUserR = postCAddUserR
|
||||
postCAddUserR tid ssh csh = do
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
|
||||
|
||||
piConfirmPost <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAction)
|
||||
$logErrorS "CAddUserR" . tshow $ Aeson.encode piConfirmPost
|
||||
let
|
||||
piConfirmRes :: FormResult CourseRegisterActionData
|
||||
piConfirmRes = maybe FormMissing FormSuccess piConfirmPost
|
||||
case piConfirmRes of
|
||||
FormSuccess res'' -> do
|
||||
let res' = [res'']
|
||||
forM_ res' $ \case
|
||||
CourseRegisterActionAddTutorialMemberData{..} -> do
|
||||
registeredUsers <- registerUsers cid $ Map.singleton crActAddTutorialMemberIdent (Just $ view _1 crActAddTutorialMemberUser)
|
||||
tutId <- upsertNewTutorial cid crActAddTutorialMemberTutorial
|
||||
registerTutorialMembers tutId registeredUsers
|
||||
redirect $ CTutorialR tid ssh csh crActAddTutorialMemberTutorial TUsersR
|
||||
CourseRegisterActionAddParticipantData{..} -> do
|
||||
void . registerUsers cid $ Map.singleton crActAddParticipantIdent (Just $ view _1 crActAddParticipantUser)
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
FormMissing -> return ()
|
||||
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
||||
confirmAvailableActs <- fmap (maybe FormMissing FormSuccess) . throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAvailableActions)
|
||||
confirmActs <- fmap (maybe FormMissing FormSuccess) . throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAction)
|
||||
$logErrorS "CAddUserR available" . tshow $ Aeson.encode (confirmAvailableActs :: Maybe (Set CourseRegisterActionData))
|
||||
$logErrorS "CAddUserR acts" . tshow $ Aeson.encode (confirmActs :: Maybe (Set CourseRegisterActionData))
|
||||
if
|
||||
| FormSuccess acts <- confirmActs
|
||||
, FormSuccess _availableActs <- confirmAvailableActs
|
||||
-> do
|
||||
-- TODO: check that all acts are member of availableActs!
|
||||
forM_ (Set.toList acts) $ \case
|
||||
CourseRegisterActionAddTutorialMemberData{..} -> do
|
||||
registeredUsers <- registerUsers cid $ Map.singleton crActAddTutorialMemberIdent (Just $ view _1 crActAddTutorialMemberUser)
|
||||
tutId <- upsertNewTutorial cid crActAddTutorialMemberTutorial
|
||||
registerTutorialMembers tutId registeredUsers
|
||||
redirect $ CTutorialR tid ssh csh crActAddTutorialMemberTutorial TUsersR
|
||||
CourseRegisterActionAddParticipantData{..} -> do
|
||||
void . registerUsers cid $ Map.singleton crActAddParticipantIdent (Just $ view _1 crActAddParticipantUser)
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
| FormSuccess _ <- confirmActsRes
|
||||
-> addMessageI Error MsgCourseParticipantsRegisterConfirmInvalid
|
||||
| FormMissing <- confirmActsRes
|
||||
-> return ()
|
||||
| FormFailure errs <- confirmActsRes
|
||||
-> forM_ errs $ addMessage Error . toHtml
|
||||
|
||||
((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||
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)
|
||||
@ -177,7 +179,7 @@ postCAddUserR tid ssh csh = do
|
||||
siteLayoutMsg MsgCourseParticipantsRegisterHeading $ do
|
||||
setTitleI MsgCourseParticipantsRegisterHeading
|
||||
|
||||
actionMap :: Map CourseRegisterAction (Set CourseRegisterActionData) <- fmap Map.unions . forM usersFound $ \case
|
||||
actionMap :: Map CourseRegisterAction (Set CourseRegisterActionData) <- fmap (Map.unionsWith Set.union) . 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]
|
||||
@ -293,10 +295,7 @@ 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
|
||||
{ tutorialParticipantTutorial = tutId
|
||||
, ..
|
||||
}
|
||||
TutorialParticipant { tutorialParticipantTutorial = tutId, .. }
|
||||
[]
|
||||
let newParticipants = participants Set.\\ prevParticipants
|
||||
unless (Set.null newParticipants) $
|
||||
|
||||
Loading…
Reference in New Issue
Block a user