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

src/Handler/Course/ParticipantInvite.hs

@@ -176,7 +176,6 @@ getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler
 getCAddUserR = postCAddUserR
 postCAddUserR tid ssh csh = do
   cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-  -- mr <- getMessageRender
   today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
   currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
 
@@ -191,12 +190,6 @@ postCAddUserR tid ssh csh = do
       ( Just True )
     return $ AddUserRequest <$> auReqUsers <*> auReqTutorial
 
-  -- let dest = CourseR tid ssh csh . maybe CUsersR (flip TutorialR TUsersR . CI.mk) . join . fmap auTutorial $ formResult' usersToRegister
-  --let dest | Just AddUsers{auTutorial=Just tutn} <- formResult' usersToRegister
-  --           = CTutorialR tid ssh csh tutn TUsersR
-  --         | otherwise
-  --           = CourseR tid ssh csh CUsersR
-  -- formResultModal usersToRegister dest $ \AddUsers{..} -> hoist runDBJobs $ do
   formResult usersToAdd $ \AddUserRequest{..} -> do
     avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet upsertAvsUser auReqUsers
     let (usersFound, usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
@@ -211,45 +204,12 @@ postCAddUserR tid ssh csh = do
     if null usersFound
       then redirect currentRoute
       else do
-        (Set.toList -> registeredUsers) <- registerUsers cid avsUsers
+        registeredUsers <- registerUsers cid avsUsers
         case auReqTutorial of
           Nothing -> redirect $ CourseR tid ssh csh CUsersR
           Just tutorialName -> do
-            -- TODO: move somewhere else
+            tutId <- upsertNewTutorial cid tutorialName
-            now <- liftIO getCurrentTime
+            registerTutorialMembers tutId registeredUsers
-            runDB $ do
-              Entity tutId _ <- upsert
-                Tutorial
-                  { tutorialCourse = cid
-                  , tutorialType = CI.mk mempty -- TODO: remove type? unneeded?
-                  , tutorialCapacity = Nothing
-                  , tutorialRoom = Nothing
-                  , tutorialRoomHidden = False
-                  , tutorialTime = Occurrences mempty mempty
-                  , tutorialRegGroup = Nothing -- TODO: remove
-                  , tutorialRegisterFrom = Nothing
-                  , tutorialRegisterTo = Nothing
-                  , tutorialDeregisterUntil = Nothing
-                  , tutorialLastChanged = now
-                  , tutorialTutorControlled = False
-                  , ..
-                  }
-                [ TutorialName        =. tutorialName
-                , TutorialLastChanged =. now
-                ]
-              (Set.fromList -> prevParticipants) <- selectList [TutorialParticipantUser <-. registeredUsers, TutorialParticipantTutorial ==. tutId] []
-              (Set.fromList -> participants) <- for registeredUsers $ \tutorialParticipantUser -> upsert
-                TutorialParticipant
-                  { tutorialParticipantTutorial = tutId
-                  , ..
-                  }
-                []
-              let newParticipants = participants Set.\\ prevParticipants
-              unless (Set.null newParticipants) $
-                addMessageI Success . MsgCourseParticipantsRegisteredTutorial $ Set.size newParticipants
-              unless (Set.null prevParticipants) $
-                addMessageI Info . MsgCourseParticipantsAlreadyTutorialMember $ length prevParticipants
-            -- tell . pure <=< messageI Success . MsgCourseParticipantsRegisteredTutorial $ length uids
             redirect $ CTutorialR tid ssh csh tutorialName TUsersR
 
   let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
@@ -363,6 +323,44 @@ registerUsers cid users
       addMessageI Info . MsgCourseParticipantsAlreadyRegistered $ Set.size aurAlreadyRegistered
     return $ aurRegisterSuccess `Set.union` aurAlreadyRegistered
 
+upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId
+upsertNewTutorial cid tutorialName = do
+  now <- liftIO getCurrentTime
+  Entity tutId _ <- runDB $ upsert
+    Tutorial
+      { tutorialCourse = cid
+      , tutorialType = CI.mk mempty -- TODO: remove type? unneeded?
+      , tutorialCapacity = Nothing
+      , tutorialRoom = Nothing
+      , tutorialRoomHidden = False
+      , tutorialTime = Occurrences mempty mempty
+      , tutorialRegGroup = Nothing -- TODO: remove
+      , tutorialRegisterFrom = Nothing
+      , tutorialRegisterTo = Nothing
+      , tutorialDeregisterUntil = Nothing
+      , tutorialLastChanged = now
+      , tutorialTutorControlled = False
+      , ..
+      }
+    [ TutorialName        =. tutorialName
+    , TutorialLastChanged =. now
+    ]
+  return tutId
+
+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
+      , ..
+      }
+    []
+  let newParticipants = participants Set.\\ prevParticipants
+  unless (Set.null newParticipants) $
+    addMessageI Success . MsgCourseParticipantsRegisteredTutorial $ Set.size newParticipants
+  unless (Set.null prevParticipants) $
+    addMessageI Info . MsgCourseParticipantsAlreadyTutorialMember $ length prevParticipants
 
 --addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
 --                              => AddParticipantsResult