fix(add-users): fix and refactor confirm post param handling

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!

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!

src/Handler/Course/ParticipantInvite.hs

@@ -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)
+  confirmAvailableActs <- fmap (maybe FormMissing FormSuccess) . throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAvailableActions)
-  $logErrorS "CAddUserR" . tshow $ Aeson.encode piConfirmPost
+  confirmActs <- fmap (maybe FormMissing FormSuccess) . throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAction)
-  let
+  $logErrorS "CAddUserR available" . tshow $ Aeson.encode (confirmAvailableActs :: Maybe (Set CourseRegisterActionData))
-    piConfirmRes :: FormResult CourseRegisterActionData
+  $logErrorS "CAddUserR acts" . tshow $ Aeson.encode (confirmActs :: Maybe (Set CourseRegisterActionData))
-    piConfirmRes = maybe FormMissing FormSuccess piConfirmPost
+  if
-  case piConfirmRes of
+    | FormSuccess acts           <- confirmActs
-    FormSuccess res'' -> do
+    , FormSuccess _availableActs <- confirmAvailableActs
-      let res' = [res'']
+      -> do
-      forM_ res' $ \case
+           -- TODO: check that all acts are member of availableActs!
-        CourseRegisterActionAddTutorialMemberData{..} -> do
+           forM_ (Set.toList acts) $ \case
-          registeredUsers <- registerUsers cid $ Map.singleton crActAddTutorialMemberIdent (Just $ view _1 crActAddTutorialMemberUser)
+             CourseRegisterActionAddTutorialMemberData{..} -> do
-          tutId <- upsertNewTutorial cid crActAddTutorialMemberTutorial
+               registeredUsers <- registerUsers cid $ Map.singleton crActAddTutorialMemberIdent (Just $ view _1 crActAddTutorialMemberUser)
-          registerTutorialMembers tutId registeredUsers
+               tutId <- upsertNewTutorial cid crActAddTutorialMemberTutorial
-          redirect $ CTutorialR tid ssh csh crActAddTutorialMemberTutorial TUsersR
+               registerTutorialMembers tutId registeredUsers
-        CourseRegisterActionAddParticipantData{..} -> do
+               redirect $ CTutorialR tid ssh csh crActAddTutorialMemberTutorial TUsersR
-          void . registerUsers cid $ Map.singleton crActAddParticipantIdent (Just $ view _1 crActAddParticipantUser)
+             CourseRegisterActionAddParticipantData{..} -> do
-          redirect $ CourseR tid ssh csh CUsersR
+               void . registerUsers cid $ Map.singleton crActAddParticipantIdent (Just $ view _1 crActAddParticipantUser)
-    FormMissing -> return ()
+               redirect $ CourseR tid ssh csh CUsersR
-    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
+    | 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
+    TutorialParticipant { tutorialParticipantTutorial = tutId, .. }
-      { tutorialParticipantTutorial = tutId
-      , ..
-      }
     []
   let newParticipants = participants Set.\\ prevParticipants
   unless (Set.null newParticipants) $