diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 5e6c3b7ad..93abaedc7 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -57,13 +57,13 @@ instance Finite CourseRegisterAction data CourseRegisterActionData = CourseRegisterActionAddParticipantData - { crActAddParticipantIdent :: UserSearchKey - , crActAddParticipantUser :: (UserId, User) + { crActIdent :: UserSearchKey + , crActUser :: (UserId, User) } | CourseRegisterActionAddTutorialMemberData - { crActAddTutorialMemberIdent :: UserSearchKey - , crActAddTutorialMemberUser :: (UserId, User) - , crActAddTutorialMemberTutorial :: TutorialIdent + { crActIdent :: UserSearchKey + , crActUser :: (UserId, User) + , crActTutorial :: TutorialIdent } -- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display -- { crActUnknownPersonIdent :: Text @@ -92,9 +92,7 @@ courseRegisterRenderActionClass = \case CourseRegisterActionAddTutorialMember -> [whamlet|_{MsgCourseParticipantsRegisterActionAddTutorialMembers}|] courseRegisterRenderAction :: CourseRegisterActionData -> Widget -courseRegisterRenderAction = \case - CourseRegisterActionAddParticipantData{..} -> [whamlet|^{userWidget (view _2 crActAddParticipantUser)} (#{crActAddParticipantIdent})|] - CourseRegisterActionAddTutorialMemberData{..} -> [whamlet|^{userWidget (view _2 crActAddTutorialMemberUser)} (#{crActAddTutorialMemberIdent}), _{MsgCourseParticipantsRegisterTutorialField}: #{crActAddTutorialMemberTutorial}|] +courseRegisterRenderAction act = [whamlet|^{userWidget (view _2 (crActUser act))} (#{crActIdent act})|] data AddUserRequest = AddUserRequest @@ -126,27 +124,23 @@ postCAddUserR tid ssh csh = do currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction - $logErrorS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs - if - | not $ Set.null confirmedActs - -> do - -- TODO: check that all acts are member of availableActs! - forM_ (Set.toList confirmedActs) $ \case - CourseRegisterActionAddTutorialMemberData{..} -> do - registeredUsers <- registerUsers cid $ Map.singleton crActAddTutorialMemberIdent (Just $ view _1 crActAddTutorialMemberUser) - tutId <- upsertNewTutorial cid crActAddTutorialMemberTutorial - registerTutorialMembers tutId registeredUsers - CourseRegisterActionAddParticipantData{..} -> do - void . registerUsers cid $ Map.singleton crActAddParticipantIdent (Just $ view _1 crActAddParticipantUser) - if - | tutActs <- Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs - , CourseRegisterActionAddTutorialMemberData{..}:_ <- Set.toList tutActs - , Set.size tutActs == Set.size confirmedActs - -> redirect $ CTutorialR tid ssh csh crActAddTutorialMemberTutorial TUsersR - | otherwise - -> redirect $ CourseR tid ssh csh CUsersR - | otherwise - -> return () + $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs + unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs + let + users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs + tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs + actTutorial = fmap crActTutorial $ Set.lookupMin tutActs -- tutorial ident must be the same for every added member! + registeredUsers <- registerUsers cid users + forM_ actTutorial $ \tutName -> do + tutId <- upsertNewTutorial cid tutName + registerTutorialMembers tutId registeredUsers + + if + | Just tutName <- actTutorial + , Set.size tutActs == Set.size confirmedActs + -> redirect $ CTutorialR tid ssh csh tutName TUsersR + | otherwise + -> redirect $ CourseR tid ssh csh CUsersR ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime