diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index f65c811eb..f668b7015 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/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 - now <- liftIO getCurrentTime - 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 + tutId <- upsertNewTutorial cid tutorialName + registerTutorialMembers tutId registeredUsers 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