refactor(add-users): cleanup add-users handler

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