feat(course-users): register avs-upserted users
This commit is contained in:
Sarah Vaupel
parent
ddc71d7fd0
commit
cba73bf2ca
@ -2,6 +2,8 @@
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
-- TODO: probably remove applications in general
|
||||
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
@ -28,10 +30,10 @@ import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Handler.Course.ParticipantInvite
|
||||
-- import Handler.Course.ParticipantInvite
|
||||
import Handler.Utils.StudyFeatures
|
||||
|
||||
import Jobs.Queue
|
||||
-- import Jobs.Queue
|
||||
|
||||
|
||||
type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication)
|
||||
@ -574,7 +576,7 @@ postCApplicationsR tid ssh csh = do
|
||||
registrationOpen = maybe True (now <)
|
||||
|
||||
|
||||
((acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $
|
||||
((_acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $
|
||||
(,) <$> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsMode & setTooltip MsgAcceptApplicationsModeTip) (Just AcceptApplicationsInvite)
|
||||
<*> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsSecondary & setTooltip MsgAcceptApplicationsSecondaryTip) (Just AcceptApplicationsSecondaryTime)
|
||||
|
||||
@ -584,47 +586,47 @@ postCApplicationsR tid ssh csh = do
|
||||
, formEncoding = acceptEnc
|
||||
}
|
||||
|
||||
when mayAccept $
|
||||
formResult acceptRes $ \(invMode, appsSecOrder) -> do
|
||||
runDBJobs $ do
|
||||
Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
|
||||
let openCapacity = subtract participants <$> courseCapacity
|
||||
-- when mayAccept $
|
||||
-- formResult acceptRes $ \(invMode, appsSecOrder) -> do
|
||||
-- runDBJobs $ do
|
||||
-- -- Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
-- -- participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
|
||||
-- -- let openCapacity = subtract participants <$> courseCapacity
|
||||
|
||||
applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do
|
||||
E.on $ user E.^. UserId E.==. application E.^. CourseApplicationUser
|
||||
-- -- applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do
|
||||
-- -- E.on $ user E.^. UserId E.==. application E.^. CourseApplicationUser
|
||||
|
||||
E.where_ $ application E.^. CourseApplicationCourse E.==. E.val cid
|
||||
E.&&. E.isNothing (application E.^. CourseApplicationAllocation)
|
||||
E.&&. E.not_ (application E.^. CourseApplicationRatingVeto)
|
||||
E.&&. E.maybe E.true (`E.in_` E.valList (filter (view $ passingGrade . _Wrapped) universeF)) (application E.^. CourseApplicationRatingPoints )
|
||||
-- -- E.where_ $ application E.^. CourseApplicationCourse E.==. E.val cid
|
||||
-- -- E.&&. E.isNothing (application E.^. CourseApplicationAllocation)
|
||||
-- -- E.&&. E.not_ (application E.^. CourseApplicationRatingVeto)
|
||||
-- -- E.&&. E.maybe E.true (`E.in_` E.valList (filter (view $ passingGrade . _Wrapped) universeF)) (application E.^. CourseApplicationRatingPoints )
|
||||
|
||||
E.where_ . E.not_ . E.exists . E.from $ \participant ->
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
||||
E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId
|
||||
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
-- -- E.where_ . E.not_ . E.exists . E.from $ \participant ->
|
||||
-- -- E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
||||
-- -- E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId
|
||||
-- -- E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
|
||||
return (user, application)
|
||||
-- -- return (user, application)
|
||||
|
||||
let
|
||||
ratingL = _2 . _entityVal . _courseApplicationRatingPoints . to (Down . ExamGradeDefCenter)
|
||||
cmp = case appsSecOrder of
|
||||
AcceptApplicationsSecondaryTime
|
||||
-> comparing . view $ $(multifocusG 2) ratingL (_2 . _entityVal . _courseApplicationTime)
|
||||
AcceptApplicationsSecondaryRandom
|
||||
-> comparing $ view ratingL
|
||||
sortedApplications <- unstableSortBy cmp applications
|
||||
-- -- let
|
||||
-- -- ratingL = _2 . _entityVal . _courseApplicationRatingPoints . to (Down . ExamGradeDefCenter)
|
||||
-- -- cmp = case appsSecOrder of
|
||||
-- -- AcceptApplicationsSecondaryTime
|
||||
-- -- -> comparing . view $ $(multifocusG 2) ratingL (_2 . _entityVal . _courseApplicationTime)
|
||||
-- -- AcceptApplicationsSecondaryRandom
|
||||
-- -- -> comparing $ view ratingL
|
||||
-- -- sortedApplications <- unstableSortBy cmp applications
|
||||
|
||||
let applicants = sortedApplications
|
||||
& nubOrdOn (view $ _1 . _entityKey)
|
||||
& maybe id take openCapacity
|
||||
& setOf (case invMode of
|
||||
AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right
|
||||
AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left
|
||||
)
|
||||
-- -- let applicants = sortedApplications
|
||||
-- -- & nubOrdOn (view $ _1 . _entityKey)
|
||||
-- -- & maybe id take openCapacity
|
||||
-- -- & setOf (case invMode of
|
||||
-- -- AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right
|
||||
-- -- AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left
|
||||
-- -- )
|
||||
|
||||
mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
-- -- mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants
|
||||
-- redirect $ CourseR tid ssh csh CUsersR
|
||||
|
||||
let
|
||||
studyFeaturesWarning = $(i18nWidgetFile "applications-list-info")
|
||||
|
||||
@ -4,15 +4,11 @@
|
||||
|
||||
module Handler.Course.ParticipantInvite
|
||||
( getCAddUserR, postCAddUserR
|
||||
, AddParticipantsResult(..)
|
||||
, addParticipantsResultMessages
|
||||
, registerUsers, registerUser
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Course
|
||||
import Handler.Utils.Avs
|
||||
|
||||
import Jobs.Queue
|
||||
@ -65,7 +61,7 @@ postCAddUserR tid ssh csh = do
|
||||
return $ Map.fromSet . const <$> mTutorial <*> users
|
||||
|
||||
formResultModal usersToRegister (CourseR tid ssh csh CUsersR) $
|
||||
registerUsers cid -- TODO: register for tutorial, if specified
|
||||
hoist runDBJobs . registerUsers cid -- TODO: register for tutorial, if specified
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
|
||||
|
||||
@ -77,20 +73,18 @@ postCAddUserR tid ssh csh = do
|
||||
}
|
||||
|
||||
|
||||
registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] Handler ()
|
||||
registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] (YesodJobDB UniWorX) ()
|
||||
registerUsers cid usersToRegister = do
|
||||
avsUsers :: Map Text (Maybe UserId) <- fmap Map.fromList . forM (Map.keys usersToRegister) $ \userIdent -> do
|
||||
mUser <- liftHandler $ upsertAvsUser userIdent -- TODO: upsertAvsUser should return whole Entity
|
||||
return (userIdent, mUser)
|
||||
|
||||
when (null avsUsers) $
|
||||
tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
|
||||
|
||||
-- register known users
|
||||
-- tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ imapM_ (registerUser cid) uids
|
||||
|
||||
-- unless (null avsUsers) $
|
||||
-- tell . pure <=< messageI Success . MsgCourseParticipantsAddedByAvs $ length avsUsers
|
||||
if
|
||||
| null avsUsers
|
||||
-> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven
|
||||
| otherwise
|
||||
-- register retrieved users
|
||||
-> tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (registerUser cid) (catMaybes $ Map.elems avsUsers)
|
||||
|
||||
|
||||
addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user