From 620950df83e3dc4d1f0050af4bb207d25883800e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 27 Sep 2019 11:46:25 +0200 Subject: [PATCH] feat(course-applications): automatic acceptance of direct applicants --- messages/uniworx/de.msg | 16 +- src/Handler/Course/Application/List.hs | 149 ++++++++++++++++-- src/Handler/Course/ParticipantInvite.hs | 114 ++++++++------ src/Handler/Utils/Submission.hs | 4 - src/Import/NoModel.hs | 4 + src/Model/Types/Exam.hs | 10 ++ src/Utils.hs | 16 ++ src/Yesod/Core/Types/Instances.hs | 4 + templates/course/applications-list.hamlet | 44 +++--- .../courseInvitationAlreadyRegistered.hamlet | 2 +- ...rseInvitationRegisteredWithoutField.hamlet | 2 +- 11 files changed, 275 insertions(+), 90 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index bee90fb85..f6bb5cfa4 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -173,6 +173,7 @@ CourseApplicationTemplateApplication: Bewerbungsvorlage(n) CourseApplicationTemplateRegistration: Anmeldungsvorlage(n) CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen CourseApplication: Bewerbung +CourseApplicationIsParticipant: Kursteilnehmer CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben CourseApplicationInvalidAction: Angegeben Aktion kann nicht durchgeführt werden @@ -1529,7 +1530,7 @@ CsvColumnApplicationsSemester: Fachsemester des Bewerbes im assoziierten Studien CsvColumnApplicationsText: Text-Bewerbung CsvColumnApplicationsHasFiles: Hat der Bewerber Dateien zu seiner Bewerbung eingereicht (siehe ZIP-Archiv aller Bewerbungsdateien)? CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt; "veto" oder leer -CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0" +CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0" (Leer wird behandelt wie eine Note zwischen 2.3 und 2.7) CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber Action: Aktion @@ -1785,4 +1786,15 @@ ExamCloseTip: Wenn eine Klausur abgeschlossen wird, werden Prüfungsämter, die ExamCloseReminder: Bitte schließen Sie die Klausur frühstmöglich, sobald die Prüfungsleistungen sich voraussichtlich nicht mehr ändern werden. Z.B. direkt nach der Klausureinsicht. ExamDidClose: Klausur erfolgreich abgeschlossen -ExamClosedSince time@Text: Klausur abgeschlossen seit #{time} \ No newline at end of file +ExamClosedSince time@Text: Klausur abgeschlossen seit #{time} + +BtnAcceptApplications: Bewerbungen akzeptieren +BtnAcceptApplicationsTip: Mit dem untigen Knopf können Sie den Kurs (höchstens bis zur angegeben Maximalkapazität, falls eingestellt) mit Bewerbern auffüllen. Die Bewertungen der Bewerbungen werden dabei berücksichtigt (Unbewertet wird behandelt wie eine Note zwischen 2.3 und 2.7). Bewerber mit Veto oder 5.0 werden nicht angemeldet. +AcceptApplicationsMode: Bewerbungen akzeptieren +AcceptApplicationsModeTip: Sollen akzeptierte Bewerber direkt als Teilnehmer im Kurs eingetragen werden oder sollen Einladungen per E-Mail verschickt werden? +AcceptApplicationsDirect: Direkt anmelden +AcceptApplicationsInvite: Einladungen verschicken +AcceptApplicationsSecondary: Gleichstände auflösen +AcceptApplicationsSecondaryTip: Wenn es im Laufe des Verfahrens mehrere Bewerber mit der selben Bewertung für den selben Platz gibt, wie soll der Gleichstand aufgelöst werden? +AcceptApplicationsSecondaryRandom: Zufällig +AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung \ No newline at end of file diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 312ff9d02..f3f8de21b 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -25,6 +25,10 @@ import qualified Data.Map as Map import qualified Data.Conduit.List as C +import Handler.Course.ParticipantInvite + +import Jobs.Queue + type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication) `E.InnerJoin` E.SqlExpr (Entity User) @@ -34,41 +38,49 @@ type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplic `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) ) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant)) type CourseApplicationsTableData = DBRow ( Entity CourseApplication , Entity User - , E.Value Bool -- hasFiles + , Bool -- hasFiles , Maybe (Entity Allocation) , Maybe (Entity StudyFeatures) , Maybe (Entity StudyTerms) , Maybe (Entity StudyDegree) + , Bool -- isParticipant ) courseApplicationsIdent :: Text courseApplicationsIdent = "applications" queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication)) -queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) +queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User)) -queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) +queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 4 1) queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool)) -queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) +queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) where hasFiles appl = E.exists . E.from $ \courseApplicationFile -> E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation))) -queryAllocation = to $(sqlLOJproj 3 2) +queryAllocation = to $(sqlLOJproj 4 2) queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures))) -queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3) +queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 4 3) queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms))) -queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3) +queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 4 3) queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree))) -queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 3 3) +queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 4 3) + +queryCourseParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant))) +queryCourseParticipant = to $(sqlLOJproj 4 4) + +queryIsParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool)) +queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 4 4) resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication) resultCourseApplication = _dbrOutput . _1 @@ -77,7 +89,7 @@ resultUser :: Lens' CourseApplicationsTableData (Entity User) resultUser = _dbrOutput . _2 resultHasFiles :: Lens' CourseApplicationsTableData Bool -resultHasFiles = _dbrOutput . _3 . _Value +resultHasFiles = _dbrOutput . _3 resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation) resultAllocation = _dbrOutput . _4 . _Just @@ -91,6 +103,9 @@ resultStudyTerms = _dbrOutput . _6 . _Just resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree) resultStudyDegree = _dbrOutput . _7 . _Just +resultIsParticipant :: Lens' CourseApplicationsTableData Bool +resultIsParticipant = _dbrOutput . _8 + newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -205,12 +220,44 @@ data CourseApplicationsTableCsvException instance Exception CourseApplicationsTableCsvException embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id + +data ButtonAcceptApplications = BtnAcceptApplications + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonAcceptApplications +instance Finite ButtonAcceptApplications + +nullaryPathPiece ''ButtonAcceptApplications $ camelToPathPiece' 1 + +embedRenderMessage ''UniWorX ''ButtonAcceptApplications id +instance Button UniWorX ButtonAcceptApplications where + btnClasses BtnAcceptApplications = [BCIsButton] + +data AcceptApplicationsMode = AcceptApplicationsInvite + | AcceptApplicationsDirect + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe AcceptApplicationsMode +instance Finite AcceptApplicationsMode + +nullaryPathPiece ''AcceptApplicationsMode $ camelToPathPiece' 2 + +embedRenderMessage ''UniWorX ''AcceptApplicationsMode id + +data AcceptApplicationsSecondary = AcceptApplicationsSecondaryRandom + | AcceptApplicationsSecondaryTime + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe AcceptApplicationsSecondary +instance Finite AcceptApplicationsSecondary + +nullaryPathPiece ''AcceptApplicationsSecondary $ camelToPathPiece' 3 + +embedRenderMessage ''UniWorX ''AcceptApplicationsSecondary id + getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCApplicationsR = postCApplicationsR postCApplicationsR tid ssh csh = do - (table, allocationsBounds) <- runDB $ do + (table, allocationsBounds, mayAccept) <- runDB $ do Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh) @@ -237,31 +284,43 @@ postCApplicationsR tid ssh csh = do studyFeatures <- view queryStudyFeatures studyTerms <- view queryStudyTerms studyDegree <- view queryStudyDegree + courseParticipant <- view queryCourseParticipant lift $ do + E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser + E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid) E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser - E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid + E.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid - return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree) + return ( courseApplication + , user + , hasFiles + , allocation + , studyFeatures + , studyTerms + , studyDegree + , E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId + ) dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData dbtProj = runReaderT $ do - appId <- view $ resultCourseApplication . _entityKey + appId <- view $ _dbrOutput . _1 . _entityKey cID <- encrypt appId guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR - view id + asks $ over (_dbrOutput . _3) E.unValue . over (_dbrOutput . _8) E.unValue dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId) dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat - [ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand) + [ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant + , emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand) , anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey) , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) @@ -276,7 +335,8 @@ postCApplicationsR tid ssh csh = do ] dbtSorting = mconcat - [ sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand) + [ singletonMap "participant" . SortColumn $ view queryIsParticipant + , sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand) , sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname)) , sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer) , sortStudyTerms queryStudyTerms @@ -566,12 +626,67 @@ postCApplicationsR tid ssh csh = do || numFirstChoice' /= numFirstChoice ] - (, allocationsBounds) <$> dbTableWidget' psValidator DBTable{..} + mayAccept <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR + + (, allocationsBounds, mayAccept) <$> dbTableWidget' psValidator DBTable{..} now <- liftIO getCurrentTime let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle registrationOpen = maybe True (now <) + + ((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) + + let acceptWgt = wrapForm' BtnAcceptApplications acceptWgt' def + { formSubmit = FormSubmit + , formAction = Just . SomeRoute $ CourseR tid ssh csh CApplicationsR + , formEncoding = acceptEnc + } + + when mayAccept $ + formResult acceptRes $ \(invMode, appsSecOrder) -> do + runDBJobs $ do + Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh + participants <- count [ CourseParticipantCourse ==. cid ] + let openCapacity = subtract participants <$> courseCapacity + + 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_ . E.not_ . E.exists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId + + 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 applicants = sortedApplications + & nubOn (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 + + siteLayoutMsg title $ do setTitleI title $(widgetFile "course/applications-list") diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index e2962ac0b..9459346a3 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -4,6 +4,9 @@ module Handler.Course.ParticipantInvite ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..) , getCInviteR, postCInviteR , getCAddUserR, postCAddUserR + , AddParticipantsResult(..) + , addParticipantsResultMessages + , registerUsers, registerUser ) where import Import @@ -96,16 +99,16 @@ participantInvitationConfig = InvitationConfig{..} return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR -data AddRecipientsResult = AddRecipientsResult +data AddParticipantsResult = AddParticipantsResult { aurAlreadyRegistered , aurNoUniquePrimaryField - , aurSuccess :: [UserEmail] + , aurSuccess :: Set UserId } deriving (Read, Show, Generic, Typeable) -instance Semigroup AddRecipientsResult where +instance Semigroup AddParticipantsResult where (<>) = mappenddefault -instance Monoid AddRecipientsResult where +instance Monoid AddParticipantsResult where mempty = memptydefault mappend = (<>) @@ -118,7 +121,9 @@ postCAddUserR tid ssh csh = do wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) (fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing - formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid + formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ + hoist runDBJobs . registerUsers cid + let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading @@ -128,57 +133,74 @@ postCAddUserR tid ssh csh = do { formEncoding , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR } - where - processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler () - processUsers cid users = do - let (emails,uids) = partitionEithers $ Set.toList users - AddRecipientsResult{..} <- lift . runDBJobs $ do - -- send Invitation eMails to unkown users - sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails] - -- register known users - execWriterT $ mapM (registerUser cid) uids - unless (null emails) $ - tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails +registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) () +registerUsers cid users = do + let (emails,uids) = partitionEithers $ Set.toList users - unless (null aurAlreadyRegistered) $ do - let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] - modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") - tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) + -- send Invitation eMails to unkown users + lift $ sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails] + -- register known users + tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT $ mapM_ (registerUser cid) uids - unless (null aurNoUniquePrimaryField) $ do - let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|] - modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField") - tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) + unless (null emails) $ + tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails - unless (null aurSuccess) $ - tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess - registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) () - registerUser cid uid = exceptT tell tell $ do - User{..} <- lift . lift $ getJust uid +addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) + => AddParticipantsResult + -> ReaderT (YesodPersistBackend UniWorX) m [Message] +addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do + (aurAlreadyRegistered', aurNoUniquePrimaryField') <- + (,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered) + <*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField) - whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ - throwError $ mempty { aurAlreadyRegistered = pure userEmail } + unless (null aurAlreadyRegistered) $ do + let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] + modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") + tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) - features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] + unless (null aurNoUniquePrimaryField) $ do + let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|] + modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField") + tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) - let courseParticipantField - | [f] <- features = Just f - | otherwise = Nothing + unless (null aurSuccess) $ + tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess - courseParticipantRegistration <- liftIO getCurrentTime - void . lift . lift . insert $ CourseParticipant - { courseParticipantCourse = cid - , courseParticipantUser = uid - , courseParticipantAllocated = False - , .. - } - lift . lift . audit $ TransactionCourseParticipantEdit cid uid - return $ case courseParticipantField of - Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } - Just _ -> mempty { aurSuccess = pure userEmail } +registerUser :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) + => CourseId + -> UserId + -> WriterT AddParticipantsResult (ReaderT (YesodPersistBackend UniWorX) m) () +registerUser cid uid = exceptT tell tell $ do + whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ + throwError $ mempty { aurAlreadyRegistered = Set.singleton uid } + + features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] + applications <- lift . lift $ selectList [ CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] + + let courseParticipantField + | [f] <- features + = Just f + | [f'] <- nub $ mapMaybe (courseApplicationField . entityVal) applications + , f' `elem` features + = Just f' + | otherwise + = Nothing + + courseParticipantRegistration <- liftIO getCurrentTime + void . lift . lift . insert $ CourseParticipant + { courseParticipantCourse = cid + , courseParticipantUser = uid + , courseParticipantAllocated = False + , .. + } + lift . lift . audit $ TransactionCourseParticipantEdit cid uid + + return $ case courseParticipantField of + Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid } + Just _ -> mempty { aurSuccess = Set.singleton uid } getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 383e7fe4e..4df32cd24 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -20,7 +20,6 @@ import Control.Monad.State.Class as State import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter) import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST) import qualified Control.Monad.Random as Rand -import qualified System.Random.Shuffle as Rand (shuffleM) import Data.Maybe () @@ -248,9 +247,6 @@ planSubmissions sid restriction = do maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs - unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a] - unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp - submissionFileSource :: SubmissionId -> ConduitT () (Entity File) (YesodDB UniWorX) () submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index bbc0f02d9..ec4e44c34 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -88,6 +88,10 @@ import Control.Monad.Trans.State as Import ( state, State, runState, mapState, withState , StateT(..), mapStateT, withStateT ) +import Control.Monad.Trans.Writer.Lazy as Import + ( writer, Writer, runWriter, mapWriter, execWriter + , WriterT(..), mapWriterT, execWriterT + ) import Control.Monad.Base as Import import Control.Monad.Catch as Import hiding (Handler(..)) import Control.Monad.Trans.Control as Import hiding (embed) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 1a3f3ec0d..d7a1ae6e3 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -13,6 +13,7 @@ module Model.Types.Exam , ExamOccurrenceRule(..) , ExamGrade(..) , numberGrade + , ExamGradeDefCenter(..) , ExamGradingRule(..) , ExamPassed(..) , passingGrade @@ -218,6 +219,15 @@ instance PersistFieldSql ExamGrade where sqlType _ = SqlNumeric 2 1 +newtype ExamGradeDefCenter = ExamGradeDefCenter { examGradeDefCenter :: Maybe ExamGrade } + deriving (Eq, Read, Show, Generic, Typeable) + +instance Ord ExamGradeDefCenter where + ExamGradeDefCenter Nothing <= ExamGradeDefCenter (Just g) = Grade23 <= g + ExamGradeDefCenter (Just g) <= ExamGradeDefCenter Nothing = g <= Grade27 + ExamGradeDefCenter g <= ExamGradeDefCenter g' = g <= g' + + data ExamGradingRule = ExamGradingKey { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@ diff --git a/src/Utils.hs b/src/Utils.hs index 65b748db9..28c88912d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -85,6 +85,9 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded import Data.Constraint (Dict(..)) +import Control.Monad.Random.Class (MonadRandom) +import qualified System.Random.Shuffle as Rand (shuffleM) + {-# ANN module ("HLint: ignore Use asum" :: String) #-} @@ -953,3 +956,16 @@ clampMin, clampMax :: Ord a -> a -- ^ Clamped Value clampMin = max clampMax = min + +------------ +-- Random -- +------------ + +unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a] +unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp + +unstableSortOn :: (MonadRandom m, Ord b) => (a -> b) -> [a] -> m [a] +unstableSortOn = unstableSortBy . comparing + +unstableSort :: (MonadRandom m, Ord a) => [a] -> m [a] +unstableSort = unstableSortBy compare diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index c5bc29c8b..8af451314 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -26,6 +26,7 @@ import Control.Monad.Trans.Reader (ReaderT, mapReaderT, runReaderT) import Control.Monad.Base (MonadBase) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Catch (MonadMask, MonadCatch) +import Control.Monad.Random.Class (MonadRandom) deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site) @@ -40,6 +41,9 @@ deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site) deriving via (ReaderT (HandlerData site site) IO) instance MonadBase IO (HandlerFor site) deriving via (ReaderT (WidgetData site) IO) instance MonadBase IO (WidgetFor site) +deriving via (ReaderT (HandlerData site site) IO) instance MonadRandom (HandlerFor site) +deriving via (ReaderT (WidgetData site) IO) instance MonadRandom (WidgetFor site) + -- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo` newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a } diff --git a/templates/course/applications-list.hamlet b/templates/course/applications-list.hamlet index 9cb6253fc..fde01d6e1 100644 --- a/templates/course/applications-list.hamlet +++ b/templates/course/applications-list.hamlet @@ -1,22 +1,28 @@ $newline never $if not (null allocationsBounds) -

_{MsgCourseAllocationsBounds (length allocationsBounds)} -
- $forall (Allocation{allocationName, allocationRegisterTo}, numApps, numFirstChoice, capped) <- allocationsBounds -
- #{allocationName} -
-

- $if numApps == numFirstChoice - _{MsgCourseAllocationsBoundCoincide numFirstChoice} - $else - _{MsgCourseAllocationsBound numApps numFirstChoice} - $if capped -

- _{MsgCourseAllocationsBoundCapped} - $if registrationOpen allocationRegisterTo -

- _{MsgCourseAllocationsBoundWarningOpen} +

+

_{MsgCourseAllocationsBounds (length allocationsBounds)} +
+ $forall (Allocation{allocationName, allocationRegisterTo}, numApps, numFirstChoice, capped) <- allocationsBounds +
+ #{allocationName} +
+

+ $if numApps == numFirstChoice + _{MsgCourseAllocationsBoundCoincide numFirstChoice} + $else + _{MsgCourseAllocationsBound numApps numFirstChoice} + $if capped +

+ _{MsgCourseAllocationsBoundCapped} + $if registrationOpen allocationRegisterTo +

+ _{MsgCourseAllocationsBoundWarningOpen} +$if mayAccept +

+

_{MsgBtnAcceptApplicationsTip} + ^{acceptWgt} -

_{MsgMenuCourseApplications} -^{table} +
+

_{MsgMenuCourseApplications} + ^{table} diff --git a/templates/messages/courseInvitationAlreadyRegistered.hamlet b/templates/messages/courseInvitationAlreadyRegistered.hamlet index bf0d3af6b..ba9c16c59 100644 --- a/templates/messages/courseInvitationAlreadyRegistered.hamlet +++ b/templates/messages/courseInvitationAlreadyRegistered.hamlet @@ -1,5 +1,5 @@

_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}
    - $forall email <- aurAlreadyRegistered + $forall email <- aurAlreadyRegistered'
  • #{email} diff --git a/templates/messages/courseInvitationRegisteredWithoutField.hamlet b/templates/messages/courseInvitationRegisteredWithoutField.hamlet index cad133fcb..a03358c00 100644 --- a/templates/messages/courseInvitationRegisteredWithoutField.hamlet +++ b/templates/messages/courseInvitationRegisteredWithoutField.hamlet @@ -1,5 +1,5 @@

    _{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}
      - $forall email <- aurNoUniquePrimaryField + $forall email <- aurNoUniquePrimaryField'
    • #{email}