From 727d78cabc01e9f520b7140336bdacebc6188e2b Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 12 Dec 2022 12:28:05 +0100 Subject: [PATCH] fix(add-users): fix and refactor confirm post param handling --- .../courses/courses/de-de-formal.msg | 1 + .../categories/courses/courses/en-eu.msg | 1 + src/Handler/Course/ParticipantInvite.hs | 59 +++++++++---------- 3 files changed, 31 insertions(+), 30 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 7c75e26b3..58be4572d 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -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! diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 1741c9f35..436f2791e 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -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! diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 386013fb3..8a2957aa0 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel +-- SPDX-FileCopyrightText: 2022 Sarah Vaupel -- -- 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) $