fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(users-add): upsert tutorial only if users not empty

Browse Source
This commit is contained in:
Sarah Vaupel 2022-12-10 00:28:35 +01:00
parent 662445e8cc
commit e65d38898e
1 changed files with 45 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
src/Handler/Course/ParticipantInvite.hs
View File

@ -73,36 +73,42 @@ postCAddUserR tid ssh csh = do
| otherwise
= CourseR tid ssh csh CUsersR
formResultModal usersToRegister dest $ \AddUsers{..} -> hoist runDBJobs $ do
uids <- registerUsers cid auUsers
for_ auTutorial $ \tutorialName -> lift $ do
-- TODO: move somewhere else
now <- liftIO getCurrentTime
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
]
for_ uids $ \tutorialParticipantUser -> upsert
TutorialParticipant
{ tutorialParticipantTutorial = tutId
, ..
}
[]
-- tell . pure <=< messageI Success . MsgCourseParticipantsRegisteredTutorial $ length uids
avsUsers :: Map Text (Maybe UserId) <- sequenceA . flip Map.fromSet auUsers $ liftHandler . upsertAvsUser
let retrievedUsers = catMaybes $ Map.elems avsUsers
if
| uids@(_:_) <- retrievedUsers -> do
registerUsers cid avsUsers
for_ auTutorial $ \tutorialName -> lift $ do
-- TODO: move somewhere else
now <- liftIO getCurrentTime
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
]
for_ uids $ \tutorialParticipantUser -> upsert
TutorialParticipant
{ tutorialParticipantTutorial = tutId
, ..
}
[]
-- tell . pure <=< messageI Success . MsgCourseParticipantsRegisteredTutorial $ length uids
| otherwise
-> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
@ -114,19 +120,17 @@ postCAddUserR tid ssh csh = do
}
registerUsers :: CourseId -> Set Text -> WriterT [Message] (YesodJobDB UniWorX) [UserId]
registerUsers cid auUsers = do
avsUsers :: Map Text (Maybe UserId) <- sequenceA . flip Map.fromSet auUsers $
liftHandler . upsertAvsUser -- TODO: upsertAvsUser should return whole Entity
--confirmAddUser :: ()
--confirmAddUser = do
-- siteLayoutMsg MsgCourseParticipantsRegisterConfirmationHeading $ do
-- setTitleI MsgCourseParticipantsRegisterConfirmationHeading
if
| null avsUsers
-> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
| otherwise
-- register retrieved users
-> tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT . mapM_ (registerUser cid) $ Map.toList avsUsers
return . catMaybes $ Map.elems avsUsers
registerUsers :: CourseId -> Map Text (Maybe UserId) -> WriterT [Message] (YesodJobDB UniWorX) ()
registerUsers cid users
| null users = tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
| otherwise = tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT . mapM_ (registerUser cid) $ Map.toList users
addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)