diff --git a/frontend/src/app.sass b/frontend/src/app.sass index b87ab6172..9e1d04814 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -903,7 +903,7 @@ th, td right: 5px top: 5px -.occurrence--not-registered, .no-bonus, .allocation-course--excluded +.occurrence--not-registered, .no-bonus, .allocation-course--excluded, .allocation-course--inactive text-decoration: line-through .result diff --git a/frontend/src/services/http-client/http-client.js b/frontend/src/services/http-client/http-client.js index a427a46e3..274f86cdb 100644 --- a/frontend/src/services/http-client/http-client.js +++ b/frontend/src/services/http-client/http-client.js @@ -49,7 +49,7 @@ export class HttpClient { } _fetch(options) { - options.url = options.url || this._defaultUrl; + options.url = (options.url && options.url.href) || options.url || this._defaultUrl; if (this._baseUrl && options.url && options.url.substring(0,1) === '/' && options.url.substring(0,2) !== '//') options.url = this._baseUrl + (this._baseUrl.substring(this._baseUrl.substring.length - 1) === '/' ? '' : '/') + options.url.substring(1,0); diff --git a/frontend/src/utils/inputs/radio-group.sass b/frontend/src/utils/inputs/radio-group.sass index 367a05702..32313b488 100644 --- a/frontend/src/utils/inputs/radio-group.sass +++ b/frontend/src/utils/inputs/radio-group.sass @@ -4,52 +4,52 @@ .radio-group display: flex -.radio - position: relative - display: inline-block + .radio + position: relative + display: inline-block - [type='radio'] - position: fixed - top: -1px - left: -1px - width: 1px - height: 1px - overflow: hidden + [type='radio'] + position: fixed + top: -1px + left: -1px + width: 1px + height: 1px + overflow: hidden - label - display: block - height: 34px - min-width: 42px - line-height: 34px - text-align: center - padding: 0 13px - background-color: #f3f3f3 - box-shadow: inset 2px 1px 2px 1px rgba(50, 50, 50, 0.05) - color: var(--color-font) - cursor: pointer + label + display: block + height: 34px + min-width: 42px + line-height: 34px + text-align: center + padding: 0 13px + background-color: #f3f3f3 + box-shadow: inset 2px 1px 2px 1px rgba(50, 50, 50, 0.05) + color: var(--color-font) + cursor: pointer - \:checked + label - background-color: var(--color-primary) - color: var(--color-lightwhite) - box-shadow: inset -2px -1px 2px 1px rgba(255, 255, 255, 0.15) + \:checked + label + background-color: var(--color-primary) + color: var(--color-lightwhite) + box-shadow: inset -2px -1px 2px 1px rgba(255, 255, 255, 0.15) - \:focus + label - border-color: #3273dc - box-shadow: 0 0 0.125em 0 rgba(50, 115, 220, 0.8) - outline: 0 + \:focus + label + border-color: #3273dc + box-shadow: 0 0 0.125em 0 rgba(50, 115, 220, 0.8) + outline: 0 - [disabled] + label - pointer-events: none - border: none - opacity: 0.6 - filter: grayscale(1) + [disabled] + label + pointer-events: none + border: none + opacity: 0.6 + filter: grayscale(1) -.radio:first-child - label - border-top-left-radius: 4px - border-bottom-left-radius: 4px + .radio:first-child + label + border-top-left-radius: 4px + border-bottom-left-radius: 4px -.radio:last-child - label - border-top-right-radius: 4px - border-bottom-right-radius: 4px + .radio:last-child + label + border-top-right-radius: 4px + border-bottom-right-radius: 4px diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 2003dd3fc..6e52c454f 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2512,4 +2512,8 @@ BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwen FaqTitle: Häufig gestellte Fragen AdditionalFaqs: Weitere häufig gestellte Fragen -MultiActionUnknownAction: In einem von einem Eingabefeld abhängigen Formular wurde ein Wert gewählt, für den kein Formular verfügbar ist \ No newline at end of file +MultiActionUnknownAction: In einem von einem Eingabefeld abhängigen Formular wurde ein Wert gewählt, für den kein Formular verfügbar ist + +CourseParticipantStateIsActive: Aktive Teilnehmer +CourseParticipantStateIsInactive: Ehemalige Teilnehmer +CourseParticipantStateIsActiveFilter: Ansicht \ No newline at end of file diff --git a/models/courses.model b/models/courses.model index 12a945535..cb9839b81 100644 --- a/models/courses.model +++ b/models/courses.model @@ -53,6 +53,7 @@ CourseParticipant -- course enrolement registration UTCTime -- time of last enrolement for this course field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades allocated AllocationId Maybe -- participant was centrally allocated + state CourseParticipantState UniqueParticipant user course -- Replace the last two by the following, once an audit log is available -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student diff --git a/src/Foundation.hs b/src/Foundation.hs index 7297a70be..4f5ae399e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -757,7 +757,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of now <- liftIO getCurrentTime mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh registered <- case (mbc,mAuthId) of - (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ isJust <$> (getBy $ UniqueParticipant uid cid) + (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] _ -> return False case mbc of (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) @@ -915,6 +915,7 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh @@ -1090,19 +1091,19 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId if | courseNewsParticipantsOnly -> do uid <- hoistMaybe mAuthId - exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid + exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid True | otherwise -> return Authorized CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID - isCourseParticipant tid ssh csh participant + isCourseParticipant tid ssh csh participant False unauthorizedI MsgUnauthorizedParticipant r -> $unsupportedAuthPredicate AuthParticipant r where - isCourseParticipant tid ssh csh participant = do + isCourseParticipant tid ssh csh participant onlyActive = do let authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB () authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from @@ -1113,23 +1114,27 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh + when onlyActive $ + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive -- participant has at least one submission - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do - E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh + when (not onlyActive) $ + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is member of a submissionGroup - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh + when (not onlyActive) $ + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a sheet corrector mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet @@ -1139,13 +1144,14 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a tutorial user - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh + when (not onlyActive) $ + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is tutor for this course mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial @@ -1170,22 +1176,23 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant has an exam result for this course - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do - E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh + when (not onlyActive) $ + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do + E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is registered for an exam for this course - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - + when (not onlyActive) $ + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh return () tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of @@ -1225,7 +1232,7 @@ tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of return Authorized CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - registered <- $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] + registered <- $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate AuthCapacity r @@ -1877,6 +1884,7 @@ siteLayout' headingOverride widget = do isParticipant = E.exists . E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) @@ -2855,6 +2863,7 @@ pageActions (CourseR tid ssh csh CShowR) = do E.&&. course E.^. CourseShorthand E.==. E.val csh hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive void $ courseWhere course mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR in runDB $ mayRegister `or2M` hasParticipants diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs index db9e14512..59ea952d2 100644 --- a/src/Handler/Allocation/Accept.hs +++ b/src/Handler/Allocation/Accept.hs @@ -82,6 +82,7 @@ allocationAcceptForm aId = runMaybeT $ do E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId let participants = E.subSelectCount . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (allocationCourse, course, participants) let allocationCapacity = sumOf (folded . _2 . _entityVal . _courseCapacity . _Just) allocationCourses diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 5d0adf9de..6015f2820 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -33,6 +33,7 @@ getAShowR tid ssh ash = do courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication `E.LeftOuterJoin` registration) -> do E.on $ registration E.?. CourseParticipantCourse E.==. E.just (course E.^. CourseId) E.&&. registration E.?. CourseParticipantUser E.==. E.val muid + E.&&. registration E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId) E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index 0cd22584e..08260f683 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -45,6 +45,7 @@ queryAssignedCourses = queryAllocationUser . to queryAssignedCourses' where queryAssignedCourses' allocationUser = E.subSelectCount . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. allocationUser E.^. AllocationUserUser E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.just (allocationUser E.^. AllocationUserAllocation) + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive queryVetoedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int)) queryVetoedCourses = queryAllocationUser . to queryVetoedCourses' @@ -185,6 +186,9 @@ postAUsersR tid ssh ash = do return ( course , courseApplication E.^. CourseApplicationRatingPoints , E.just $ courseApplication E.^. CourseApplicationRatingVeto + , E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId ) coursesModalVetoed = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseApplication) -> do E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse @@ -195,6 +199,9 @@ postAUsersR tid ssh ash = do return ( course , E.nothing , E.nothing + , E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId ) coursesModalAssigned = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId @@ -204,14 +211,16 @@ postAUsersR tid ssh ash = do return ( course , E.nothing , E.nothing + , courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive ) coursesModalNewAssigned = coursesModal $ \res -> E.from $ \course -> do E.where_ $ course E.^. CourseId `E.in_` E.valList (maybe [] otoList $ Map.lookup (res ^. resultUser . _entityKey) =<< allocMatching) return ( course , E.nothing , E.nothing + , E.true ) - coursesModal :: (_ -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value (Maybe ExamGrade)), E.SqlExpr (E.Value (Maybe Bool)))) -> _ -> _ + coursesModal :: (_ -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value (Maybe ExamGrade)), E.SqlExpr (E.Value (Maybe Bool)), E.SqlExpr (E.Value Bool))) -> _ -> _ coursesModal courseSel = imapColonnade coursesModal' where coursesModal' res innerCell = review dbCell . (innerCell ^. cellAttrs, ) $ do diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 73d8ba5c3..23ab1f4f9 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1205,7 +1205,7 @@ assignHandler tid ssh csh cid assignSids = do -- gather data (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - nrParticipants <- count [CourseParticipantCourse ==. cid] + nrParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index dbdc50c61..1c7cdf6c9 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -289,6 +289,7 @@ postCApplicationsR tid ssh csh = do lift $ do E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid) + E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) 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 @@ -587,7 +588,7 @@ postCApplicationsR tid ssh csh = do psValidator = def & defaultSorting [SortAscBy "user-name"] - participants <- count [ CourseParticipantCourse ==. cid ] + participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] let remainingCapacity = subtract participants <$> courseCapacity allocationsBounds' <- E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do @@ -643,7 +644,7 @@ postCApplicationsR tid ssh csh = do formResult acceptRes $ \(invMode, appsSecOrder) -> do runDBJobs $ do Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh - participants <- count [ CourseParticipantCourse ==. cid ] + participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] let openCapacity = subtract participants <$> courseCapacity applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do @@ -657,6 +658,7 @@ postCApplicationsR tid ssh csh = do 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) diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs index a7fb00ac8..1b86fb4fd 100644 --- a/src/Handler/Course/Communication.hs +++ b/src/Handler/Course/Communication.hs @@ -40,6 +40,7 @@ postCCommR tid ssh csh = do , E.from $ \(user `E.InnerJoin` participant) -> do E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return user ) , ( RGCourseLecturers diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 5e2b5ff77..794fa74a7 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -61,11 +61,13 @@ type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int) course2Participants (course `E.InnerJoin` _school) = E.subSelectCount . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) ) => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 4cd3a3538..529bed63d 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -42,6 +42,7 @@ instance IsInvitableJunction CourseParticipant where { jParticipantRegistration :: UTCTime , jParticipantField :: Maybe StudyFeaturesId , jParticipantAllocated :: Maybe AllocationId + , jParticipantState :: CourseParticipantState } deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationDBData CourseParticipant = InvDBDataParticipant -- no data needed in DB to manage participant invitation @@ -52,8 +53,8 @@ instance IsInvitableJunction CourseParticipant where deriving (Eq, Ord, Read, Show, Generic, Typeable) _InvitableJunction = iso - (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated)) - (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated) -> CourseParticipant{..}) + (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState)) + (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState) -> CourseParticipant{..}) instance ToJSON (InvitableJunction CourseParticipant) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } @@ -95,9 +96,10 @@ participantInvitationConfig = InvitationConfig{..} now <- liftIO getCurrentTime studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing - return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing + return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do - res <- act + deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert + res <- act -- insertUnique audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup return res @@ -194,7 +196,7 @@ registerUser' :: CourseId -> Maybe SubmissionGroupName -> WriterT AddParticipantsResult (YesodJobDB UniWorX) () registerUser' cid uid mbGrp = exceptT tell tell $ do - whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ + whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $ throwError $ mempty { aurAlreadyRegistered = Set.singleton uid } features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] @@ -210,12 +212,19 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do = Nothing courseParticipantRegistration <- liftIO getCurrentTime - void . lift . lift . insert $ CourseParticipant - { courseParticipantCourse = cid - , courseParticipantUser = uid - , courseParticipantAllocated = Nothing - , .. - } + void . lift . lift $ upsert + CourseParticipant + { courseParticipantCourse = cid + , courseParticipantUser = uid + , courseParticipantAllocated = Nothing + , courseParticipantState = CourseParticipantActive + , .. + } + [ CourseParticipantRegistration =. courseParticipantRegistration + , CourseParticipantField =. courseParticipantField + , CourseParticipantAllocated =. Nothing + , CourseParticipantState =. CourseParticipantActive + ] lift . lift . audit $ TransactionCourseParticipantEdit cid uid lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index fe3eea1a9..a3f342926 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -48,7 +48,7 @@ courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course courseRegisterForm (Entity cid Course{..}) = liftHandler $ do muid <- maybeAuthId (registration, application) <- runDB $ do - registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid + registration <- fmap join . for muid $ fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy . flip UniqueParticipant cid application <- fmap (listToMaybe =<<) . for muid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] [] return (registration, application) let btn | courseApplicationsRequired @@ -160,7 +160,7 @@ getCRegisterR tid ssh csh = do Nothing -> addMessageI Info MsgLoginNecessary (Just uid) -> runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - registration <- getBy (UniqueParticipant uid cid) + registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid when (isNothing registration) $ addMessageI Warning MsgRegisterRetry redirect $ CourseR tid ssh csh CShowR @@ -199,16 +199,22 @@ postCRegisterR tid ssh csh = do = return $ Just () mkRegistration = do audit $ TransactionCourseParticipantEdit cid uid - insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures Nothing + entityKey <$> upsert + (CourseParticipant cid uid cTime crfStudyFeatures Nothing CourseParticipantActive) + [ CourseParticipantRegistration =. cTime + , CourseParticipantField =. crfStudyFeatures + , CourseParticipantAllocated =. Nothing + , CourseParticipantState =. CourseParticipantActive + ] case courseRegisterButton of BtnCourseRegister -> runDB $ do - regOk <- (\app reg -> (,) <$> app <*> reg) <$> mkApplication <*> mkRegistration + regOk <- (\app reg -> (, reg) <$> app) <$> mkApplication <*> mkRegistration case regOk of Nothing -> transactionUndo Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk BtnCourseDeregister -> runDB $ do - part <- getBy $ UniqueParticipant uid cid + part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid forM_ part $ \(Entity _partId CourseParticipant{..}) -> do when (is _Just courseParticipantAllocated) $ do now <- liftIO getCurrentTime @@ -243,9 +249,9 @@ deleteApplicationFiles appId = do deregisterParticipant :: UserId -> CourseId -> DB () deregisterParticipant uid cid = do deleteApplications uid cid - part <- getBy $ UniqueParticipant uid cid + part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid forM_ part $ \(Entity partId CourseParticipant{..}) -> do - delete $ partId + update partId [CourseParticipantState =. CourseParticipantInactive False] audit $ TransactionCourseParticipantDeleted cid uid examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index dc14e2095..e74d226da 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -32,6 +32,7 @@ getCShowR tid ssh csh = do \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser + E.&&. participant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh @@ -40,6 +41,7 @@ getCShowR tid ssh csh = do let numParticipants :: E.SqlExpr (E.Value Int) numParticipants = E.subSelectCount . E.from $ \part -> E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. part E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (course,school E.^. SchoolName, numParticipants, participant) staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index cd40e1ed0..f5568c5ca 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -55,7 +55,7 @@ postCUserR tid ssh csh uCId = do uid <- decrypt uCId course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh user <- get404 uid - registered <- existsBy $ UniqueParticipant uid cid + registered <- exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ] return (course, Entity uid user, registered) @@ -90,7 +90,7 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = currentRoute <- MaybeT getCurrentRoute (mRegistration, studies) <- lift . runDB $ do - registration <- getBy $ UniqueParticipant uid cid + registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId @@ -167,17 +167,18 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = = Just featId | otherwise = Nothing - pId <- lift . runDBJobs $ do - pId <- insertUnique $ CourseParticipant cid uid now field Nothing - when (is _Just pId) $ do - queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid - audit $ TransactionCourseParticipantEdit cid uid - return pId - case pId of - Just _ -> do - addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk - redirect currentRoute - Nothing -> invalidArgs ["User already registered"] + lift . runDBJobs $ do + void $ upsert + (CourseParticipant cid uid now field Nothing CourseParticipantActive) + [ CourseParticipantRegistration =. now + , CourseParticipantField =. field + , CourseParticipantAllocated =. Nothing + , CourseParticipantState =. CourseParticipantActive + ] + queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid + audit $ TransactionCourseParticipantEdit cid uid + addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk + redirect currentRoute _other -> error "Invalid @regButton@" mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index c2ab01c15..01d2baf02 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -71,7 +71,7 @@ querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 4 4) userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User) - , E.SqlExpr (E.Value UTCTime) + , E.SqlExpr (Entity CourseParticipant) , E.SqlExpr (E.Value (Maybe (Key CourseUserNote))) , StudyFeaturesDescription' , E.SqlExpr (Maybe (Entity SubmissionGroup)) @@ -86,11 +86,11 @@ userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.L E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid)) E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid - return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features, subGroup) + return (user, participant, note E.?. CourseUserNoteId, features, subGroup) type UserTableData = DBRow ( Entity User - , UTCTime + , Entity CourseParticipant , Maybe CourseUserNoteId , (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) @@ -104,8 +104,11 @@ instance HasEntity UserTableData User where instance HasUser UserTableData where hasUser = _dbrOutput . _1 . _entityVal +_userTableParticipant :: Lens' UserTableData (Entity CourseParticipant) +_userTableParticipant = _dbrOutput . _2 + _userTableRegistration :: Lens' UserTableData UTCTime -_userTableRegistration = _dbrOutput . _2 +_userTableRegistration = _userTableParticipant . _entityVal . _courseParticipantRegistration _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId) _userTableNote = _dbrOutput . _3 @@ -326,7 +329,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q) dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms), subGroup) -> do + dbtProj = traverse $ \(user, participant, E.Value userNoteId, (feature,degree,terms), subGroup) -> do tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] [] exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] [] let @@ -334,7 +337,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts' exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams - return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts, exs, subGroup) + return (user, participant, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts, exs, subGroup) dbtColonnade = colChoices dbtSorting = mconcat [ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header @@ -408,10 +411,12 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do -- , ("course-registration", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO , single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) + , single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState)) ] where single = uncurry Map.singleton dbtFilterUI mPrev = mconcat $ - [ fltrUserNameEmailUI mPrev + [ prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt (courseParticipantStateIsActiveField . Just $ SomeMessage MsgNoFilter) (fslI MsgCourseParticipantStateIsActiveFilter) + , fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev ] ++ [ fltrUserSexUI mPrev | showSex ] ++ @@ -505,6 +510,7 @@ courseUserDeregisterForm cid = wFormToAForm $ do allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated) + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive if | allocated -> do wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip fmap CourseUserDeregisterData <$> optionalActionW (apreq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True) @@ -540,10 +546,11 @@ postCUsersR tid ssh csh = do , guardOn hasSubmissionGroups colUserSubmissionGroup , guardOn hasTutorials $ colUserTutorials tid ssh csh , guardOn hasExams $ colUserExams tid ssh csh - , pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration) + , pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (maybe mempty dateCell . preview (_Just . _userTableRegistration) . assertM' (has $ _userTableParticipant . _entityVal . _courseParticipantState . _CourseParticipantActive)) , pure $ colUserComment tid ssh csh ] psValidator = def & defaultSortingByName + & defaultFilter (singletonMap "active" [toPathPiece True]) hasExams = not $ null exams examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId)) examOccActs = examOccurrencesPerExam @@ -587,7 +594,7 @@ postCUsersR tid ssh csh = do | otherwise -> mempty ] - numParticipants <- count [CourseParticipantCourse ==. cid] + numParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True) return (ent, numParticipants, table) formResult participantRes $ \case @@ -597,7 +604,7 @@ postCUsersR tid ssh csh = do (CourseUserDeregisterData{..}, selectedUsers) -> do Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do now <- liftIO getCurrentTime - Entity _ CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid + Entity _ CourseParticipant{..} <- MaybeT . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid lift $ deregisterParticipant courseParticipantUser courseParticipantCourse case deregisterReason of Just reason @@ -613,10 +620,11 @@ postCUsersR tid ssh csh = do addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers redirect $ CourseR tid ssh csh CUsersR (CourseUserRegisterExamData{..}, selectedUsers) -> do - Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do + Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do + guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] now <- liftIO getCurrentTime let (exam, mOccurrence) = registerExam - mExamReg <- insertUnique ExamRegistration + mExamReg <- lift $ insertUnique ExamRegistration { examRegistrationExam = exam , examRegistrationUser = uid , examRegistrationOccurrence = mOccurrence @@ -624,7 +632,7 @@ postCUsersR tid ssh csh = do } case mExamReg of Just _ -> do - audit $ TransactionExamRegister exam uid + lift . audit $ TransactionExamRegister exam uid return 1 Nothing -> return mempty diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index feee5ddc1..930547721 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -127,7 +127,7 @@ postEAddUserR tid ssh csh examn = do whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $ throwError $ mempty { aurAlreadyRegistered = pure userEmail } - whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ do + whenM (lift . lift $ exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ]) $ do lift $ lift examRegister throwError $ mempty { aurSuccess = pure userEmail } @@ -142,13 +142,20 @@ postEAddUserR tid ssh csh examn = do | [f] <- features = Just f | otherwise = Nothing - lift . lift . insert_ $ CourseParticipant - { courseParticipantCourse = cid - , courseParticipantUser = uid - , courseParticipantRegistration = now - , courseParticipantAllocated = Nothing - , .. - } + lift . lift . void $ upsert + CourseParticipant + { courseParticipantCourse = cid + , courseParticipantUser = uid + , courseParticipantRegistration = now + , courseParticipantAllocated = Nothing + , courseParticipantState = CourseParticipantActive + , .. + } + [ CourseParticipantRegistration =. now + , CourseParticipantAllocated =. Nothing + , CourseParticipantField =. courseParticipantField + , CourseParticipantState =. CourseParticipantActive + ] lift . lift . audit $ TransactionCourseParticipantEdit cid uid lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid lift $ lift examRegister diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 68ad7cd72..0087c26c0 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -90,7 +90,7 @@ examRegistrationInvitationConfig = InvitationConfig{..} return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do - isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse + isRegistered <- fmap (is _Just) . liftHandler . runDB . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive). getBy $ UniqueParticipant uid examCourse now <- liftIO getCurrentTime case (isRegistered, invDBExamRegistrationCourseRegister) of @@ -101,7 +101,13 @@ examRegistrationInvitationConfig = InvitationConfig{..} (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do whenIsJust mField $ \cpField -> do - insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing + void $ upsert + (CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing CourseParticipantActive) + [ CourseParticipantRegistration =. examRegistrationTime + , CourseParticipantField =. cpField + , CourseParticipantAllocated =. Nothing + , CourseParticipantState =. CourseParticipantActive + ] queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index e567406c9..af8d807e1 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -471,6 +471,7 @@ postEUsersR tid ssh csh examn = do E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) + E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId @@ -758,13 +759,20 @@ postEUsersR tid ssh csh examn = do C.mapM_ $ \case ExamUserCsvCourseRegisterData{..} -> do now <- liftIO getCurrentTime - insert_ CourseParticipant - { courseParticipantCourse = examCourse - , courseParticipantUser = examUserCsvActUser - , courseParticipantRegistration = now - , courseParticipantField = examUserCsvActCourseField - , courseParticipantAllocated = Nothing - } + void $ upsert + CourseParticipant + { courseParticipantCourse = examCourse + , courseParticipantUser = examUserCsvActUser + , courseParticipantRegistration = now + , courseParticipantField = examUserCsvActCourseField + , courseParticipantAllocated = Nothing + , courseParticipantState = CourseParticipantActive + } + [ CourseParticipantRegistration =. now + , CourseParticipantField =. examUserCsvActCourseField + , CourseParticipantAllocated =. Nothing + , CourseParticipantState =. CourseParticipantActive + ] queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser insert_ ExamRegistration @@ -971,7 +979,7 @@ postEUsersR tid ssh csh examn = do , GuessUserFirstName <$> csvEUserFirstName ] pid <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria - (,) <$> existsBy (UniqueParticipant pid examCourse) <*> pure pid + (,) <$> exists [CourseParticipantCourse ==. examCourse, CourseParticipantUser ==. pid, CourseParticipantState ==. CourseParticipantActive] <*> pure pid lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId) lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 228bb0455..25458c0dd 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -261,6 +261,7 @@ postEGradesR tid ssh csh examn = do E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) + E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence) E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId) diff --git a/src/Handler/News.hs b/src/Handler/News.hs index d2cd1f9a0..f3ee2f78d 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -111,7 +111,8 @@ newsUpcomingSheets uid = do E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom) E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid - E.&&. E.maybe showSheetNoActiveTo (E.>=. E.val cTime) (sheet E.^. SheetActiveTo) + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + E.&&. E.maybe showSheetNoActiveTo (E.>=. E.val cTime) (sheet E.^. SheetActiveTo) return ( course E.^. CourseTerm @@ -224,7 +225,8 @@ newsUpcomingExams uid = do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.where_ $ E.exists $ E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid - E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight) E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now) E.&&. E.isNothing (register E.?. ExamRegistrationId) diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs index cb5923ef3..c9af17d51 100644 --- a/src/Handler/Participants.hs +++ b/src/Handler/Participants.hs @@ -46,6 +46,7 @@ getParticipantsListR = do E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId E.&&. course E.^. CourseSchool E.==. school E.^. SchoolId + E.where_ $ participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (school E.^. SchoolId, term E.^. TermId) @@ -76,6 +77,7 @@ getParticipantsR tid ssh = do E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh + E.where_ $ participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (course E.^. CourseName, user E.^. UserEmail) @@ -103,11 +105,13 @@ postParticipantsIntersectR = do E.where_ . E.exists . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val lCid + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.where_ . E.exists . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val uCid + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) - selfIntersections <- fmap Map.fromList . forM (Set.toList cids) $ \cid -> ((cid, cid), ) <$> count [CourseParticipantCourse ==. cid] + selfIntersections <- fmap Map.fromList . forM (Set.toList cids) $ \cid -> ((cid, cid), ) <$> count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] let intersections' = Map.union intersections selfIntersections courses <- sortOn (view $ _entityVal . $(multifocusL 3) _courseTerm _courseSchool _courseShorthand) <$> forM (Set.toList cids) getEntity404 return (courses, intersections') diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e10aadab4..21a31b27d 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -159,6 +159,7 @@ notificationForm template = wFormToAForm $ do , NTKCourseParticipant <- nt = fmap not . E.selectExists . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive | Just uid <- mbUid , NTKSubmissionUser <- nt = fmap not . E.selectExists . E.from $ \submissionUser -> @@ -454,6 +455,7 @@ mkEnrolledCoursesTable = , dbtSQLQuery = \(course `E.InnerJoin` participant) -> do E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (course, participant E.^. CourseParticipantRegistration) , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId , dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index dbede33a1..43be93673 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -152,6 +152,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.orderBy [E.asc $ user E.^. UserEmail] return user previousCoSubmittors :: UserId -> E.SqlQuery (E.SqlExpr (Entity User)) @@ -163,6 +164,10 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident E.where_ . E.exists . E.from $ \submissionUser' -> E.where_ $ submissionUser' E.^. SubmissionUserUser E.==. E.val uid E.&&. submissionUser' E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.where_ . 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.orderBy [E.asc $ user E.^. UserEmail] return user @@ -452,6 +457,7 @@ submissionHelper tid ssh csh shn mcid = do isParticipant = E.exists . E.from $ \courseParticipant -> do E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index 6381f8f61..33590a8ac 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -92,11 +92,20 @@ computeAllocation :: Entity Allocation , Seq MatchingLogRun ) computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = do - allocations <- selectList [ CourseParticipantAllocated ==. Just allocId ] [] + allocations <- selectList [ CourseParticipantAllocated ==. Just allocId, CourseParticipantState ==. CourseParticipantActive ] [] let allocations' = allocations & map ((, Sum 1) . courseParticipantUser . entityVal) & Map.fromListWith (<>) - & fmap getSum + + deregistrations <- E.select . E.from $ \(allocationDeregister `E.InnerJoin` courseParticipant) -> do + E.on $ courseParticipant E.^. CourseParticipantUser E.==. allocationDeregister E.^. AllocationDeregisterUser + E.&&. E.just (courseParticipant E.^. CourseParticipantCourse) E.==. allocationDeregister E.^. AllocationDeregisterCourse + E.where_ $ courseParticipant E.^. CourseParticipantState E.!=. E.val CourseParticipantActive + E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.just (E.val allocId) + return $ allocationDeregister E.^. AllocationDeregisterUser + let deregistrations' = deregistrations + & map ((, Sum 1) . E.unValue) + & Map.fromListWith (<>) users' <- selectList [ AllocationUserAllocation ==. allocId ] [] let users'' = users' @@ -105,7 +114,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d totalCourses <- lift $ allocationUserTotalCourses . entityVal priority <- MaybeT $ allocationUserPriority . entityVal - let allocated = Map.findWithDefault 0 user allocations' + let Sum allocated = Map.findWithDefault 0 user allocations' <> Map.findWithDefault 0 user deregistrations' guard $ totalCourses > allocated @@ -121,6 +130,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d let participants = E.subSelectCount . E.from $ \participant -> do E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.where_ . E.not_ . E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser @@ -145,12 +155,14 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d allocStarted <- lift $ allocationStarted allocId whenIsJust allocStarted $ \allocStarted' -> do - let partDeleted = lift $ exists [ TransactionLogInfo ==. toJSON (TransactionCourseParticipantDeleted courseApplicationCourse courseApplicationUser), TransactionLogTime >=. allocStarted' ] + let partDeleted = lift $ or2M + (exists [ TransactionLogInfo ==. toJSON (TransactionCourseParticipantDeleted courseApplicationCourse courseApplicationUser), TransactionLogTime >=. allocStarted' ]) + (exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser, CourseParticipantState !=. CourseParticipantActive ]) whenM partDeleted $ tellExcluded MatchingExcludedParticipationExisted let partExists :: StateT _ DB Bool - partExists = lift $ exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser ] + partExists = lift $ exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser, CourseParticipantState ==. CourseParticipantActive ] whenM partExists $ tellExcluded MatchingExcludedParticipationExists @@ -233,7 +245,14 @@ doAllocation :: AllocationId doAllocation allocId now regs = forM_ regs $ \(uid, cid) -> do mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] [] - void . insertUnique $ CourseParticipant cid uid now mField (Just allocId) + void $ upsert + (CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive) + [ CourseParticipantRegistration =. now + , CourseParticipantField =. mField + , CourseParticipantAllocated =. Just allocId + , CourseParticipantState =. CourseParticipantActive + ] + audit $ TransactionCourseParticipantEdit cid uid ppMatchingLog :: Seq MatchingLogRun -> Text ppMatchingLog = unlines . map prettyRun . otoList diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 82fea28e1..c9e0a314c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1294,24 +1294,20 @@ boolField :: ( MonadHandler m , HandlerSite m ~ UniWorX ) => Maybe (SomeMessage UniWorX) -> Field m Bool -boolField mkNone = Field - { fieldParse = \e _ -> return $ boolParser e - , fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool") - , fieldEnctype = UrlEncoded - } - where - boolParser [] = Right Nothing - boolParser (x:_) = case x of - "" -> Right Nothing - "none" -> Right Nothing - "yes" -> Right $ Just True - "on" -> Right $ Just True - "no" -> Right $ Just False - "true" -> Right $ Just True - "false" -> Right $ Just False - t -> Left $ SomeMessage $ MsgInvalidBool t - showVal = either $ const False - +boolField mkNone = radioGroupField mkNone $ do + mr <- getMessageRender + return OptionList + { olOptions = [ Option (mr MsgBoolNo ) False "no" + , Option (mr MsgBoolYes) True "yes" + ] + , olReadExternal = \case + "yes" -> Just True + "on" -> Just True + "no" -> Just False + "true" -> Just True + "false" -> Just False + _other -> Nothing + } @@ -1859,3 +1855,19 @@ labeledCheckBoxView :: Widget labeledCheckBoxView label theId name attrs val isReq = $(widgetFile "widgets/fields/labeled-checkbox") where checkBoxView = fieldView (checkBoxField :: Field Handler Bool) theId name attrs val isReq + + +newtype CourseParticipantStateIsActive = CourseParticipantStateIsActive { getCourseParticipantStateIsActive :: Bool } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Universe, Finite) + +embedRenderMessageVariant ''UniWorX ''CourseParticipantStateIsActive $ \case + "True" -> "CourseParticipantStateIsActive" + "False" -> "CourseParticipantStateIsInactive" + _ -> error "Unexpected constructor for Bool" +finitePathPiece ''CourseParticipantStateIsActive + ["inactive", "active"] +makeWrapped ''CourseParticipantStateIsActive + +courseParticipantStateIsActiveField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (SomeMessage UniWorX) -> Field m Bool +courseParticipantStateIsActiveField optMsg = hoistField liftHandler . isoField (_Wrapped @CourseParticipantStateIsActive) $ radioGroupField optMsg optionsFinite diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 6ffbf56fe..8ea5b6aaa 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -333,6 +333,14 @@ piIsUnset PaginationInput{..} = and , isNothing piPage ] +psToPi :: PaginationSettings -> PaginationInput +psToPi PaginationSettings{..} = PaginationInput + { piSorting = Just psSorting + , piFilter = Just psFilter + , piLimit = Just psLimit + , piPage = Just psPage + } + data DBCsvActionMode = DBCsvActionNew | DBCsvActionExisting | DBCsvActionMissing deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, Typeable) @@ -886,10 +894,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db <*> iopt intField (wIdent "page") let prevPi - | FormSuccess pi <- piPreviousRes <|> piInput - = pi - | otherwise - = def + = views _2 psToPi . runPSValidator dbtable . formResultToMaybe $ piPreviousRes <|> piInput referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi @@ -901,8 +906,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db return (filterRes', pagesizeRes') let - piResult = (\fSettings -> prevPi & _piFilter .~ Just fSettings) <$> filterRes - <|> (\ps -> prevPi & _piLimit .~ Just ps) <$> pagesizeRes + piResult = (prevPi &) . (_piFilter ?~) <$> filterRes + <|> (prevPi &) . (_piLimit ?~) <$> pagesizeRes <|> piPreviousRes <|> piInput @@ -945,7 +950,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | otherwise = True - ((csvExportRes, csvExportWdgt), csvExportEnctype) <- bool runFormPost runFormGet noExportData . identifyForm (FIDDBTableCsvExport dbtIdent) . renderAForm FormDBTableCsvExport . fmap DBCsvExport $ case dbtCsvEncode of + ((csvExportRes, csvExportWdgt), csvExportEnctype) <- bool runFormPost runFormGet noExportData . addPIHiddenField dbtable paginationInput . identifyForm (FIDDBTableCsvExport dbtIdent) . renderAForm FormDBTableCsvExport . fmap DBCsvExport $ case dbtCsvEncode of Just DBTCsvEncode{..} | Just (cloneIso -> noExportData') <- dbtCsvNoExportData -> toDyn . view (noExportData' . from noExportData') <$> dbtCsvExportForm @@ -1017,8 +1022,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db res <- dbtSQLQuery t E.orderBy $ sortSql t case csvMode of - FormSuccess DBCsvExport{} -> return () - FormSuccess DBCsvImport{} -> return () + -- FormSuccess DBCsvExport{} -> return () + FormSuccess DBCsvImport{} -> return () -- don't apply filter and sorting for csv _import_; we expect all rows to be available for matching with provided csv _other -> do case previousKeys of Nothing @@ -1310,7 +1315,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db csvWdgt = $(widgetFile "table/csv-transcode") - uiLayout table = csvWdgt <> dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout") + uiLayout table = dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout") dbInvalidateResult' = foldr (<=<) return . catMaybes $ [ do diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 394516dac..eaa63d135 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -37,12 +37,14 @@ determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.where_ $ sheet E.^. SheetId E.==. E.val nSheet return user determineNotificationCandidates NotificationSheetSoonInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.where_ $ sheet E.^. SheetId E.==. E.val nSheet return user determineNotificationCandidates NotificationSheetInactive{..} @@ -82,6 +84,7 @@ determineNotificationCandidates NotificationExamRegistrationActive{..} = E.where_ . E.not_ . E.exists . E.from $ \examRegistration -> E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val nExam + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return user determineNotificationCandidates NotificationExamRegistrationSoonInactive{..} = E.select . E.from $ \(exam `E.InnerJoin` courseParticipant `E.InnerJoin` user) -> do @@ -91,6 +94,7 @@ determineNotificationCandidates NotificationExamRegistrationSoonInactive{..} = E.where_ . E.not_ . E.exists . E.from $ \examRegistration -> E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val nExam + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return user determineNotificationCandidates NotificationExamDeregistrationSoonInactive{..} = E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do @@ -218,11 +222,13 @@ determineNotificationCandidates notif@NotificationAllocationResults{..} = do E.where_ $ participant E.^. CourseParticipantUser E.==. user E.^. UserId E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) E.&&. participant E.^. CourseParticipantRegistration E.>. E.val t + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive hasAllocations t = E.exists . E.from $ \(lecturer `E.InnerJoin` participant) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.&&. lecturer E.^. LecturerCourse E.==. participant E.^. CourseParticipantCourse E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) E.&&. participant E.^. CourseParticipantRegistration E.>. E.val t + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive case lastExec of Nothing -> E.where_ $ isStudent E.||. isLecturer Just t -> E.where_ $ wasAllocated t E.||. hasAllocations t diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index c96ee4bb9..9932fef7c 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -167,9 +167,11 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi allocatedCount = E.subSelectCount . E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive let participantCount :: E.SqlExpr (E.Value Int64) participantCount = E.subSelectCount . E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (course, allocatedCount, participantCount) let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value allocCount, E.Value partCount) -> SomeMessage $ if | allocCount == partCount -> MsgAllocationResultLecturerAll courseShorthand allocCount @@ -183,6 +185,7 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) E.&&. participant E.^. CourseParticipantUser E.==. E.val jRecipient + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return course let participantResults = case participantResults' of [] | doParticipantResults -> Just [] diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 547fd3580..09c1fb331 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -34,6 +34,8 @@ import qualified Net.IPv6 as IPv6 import qualified Data.Char as Char import qualified Data.CaseInsensitive as CI +import qualified Data.Aeson as Aeson + import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage) -- Database versions must follow https://pvp.haskell.org: @@ -639,6 +641,34 @@ customMigrations = Map.fromListWith (>>) whenM (tableExists "submission_group_edit") $ tableDropEmpty "submission_group_edit" ) + , ( AppliedMigrationKey [migrationVersion|35.0.0|] [version|36.0.0|] + , whenM (tableExists "course_participant") $ do + [executeQQ| + ALTER TABLE "course_participant" ADD COLUMN "state" text NOT NULL DEFAULT 'active'; + ALTER TABLE "course_participant" ALTER COLUMN "state" text DROP DEFAULT; + |] + -- let getUsers = rawQuery [st|SELECT "id", "display_name", "surname" FROM "user"|] [] + -- updateUser (uid, firstName) = [executeQQ|UPDATE "user" SET "first_name" = #{firstName} WHERE "id" = #{uid}|] + -- splitFirstName :: [PersistValue] -> Maybe (UserId, Text) + -- splitFirstName [fromPersistValue -> Right uid, fromPersistValue -> Right displayName, fromPersistValue -> Right surname] = Just . (uid, ) $ if + -- | Just givenName <- Text.stripSuffix surname displayName + -- <|> Text.stripPrefix surname displayName + -- -> Text.strip givenName + -- | otherwise + -- -> Text.replace surname "…" displayName + -- splitFirstName _ = Nothing + -- runConduit $ getAuditLog .| C.mapM_ ensureParticipant + let getAuditLog = rawQuery [st|SELECT "info", "time" FROM "transaction_log";|] [] + ensureParticipant :: [PersistValue] -> ReaderT SqlBackend m () + ensureParticipant [fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success TransactionCourseParticipantEdit{..}), fromPersistValue -> Right (time :: UTCTime)] = do + let toAllocated :: [[PersistValue]] -> Maybe AllocationId + toAllocated = either (const Nothing) Just . fromPersistValue <=< listToMaybe <=< listToMaybe + allocated <- toAllocated <$> sourceToList [queryQQ|SELECT "allocation_course".allocation FROM "allocation_deregister" INNER JOIN "allocation_course" ON "allocation_course".course = "allocation_deregister".course WHERE "user" = #{transactionUser} AND "course" = #{transactionCourse} LIMIT 1;|] + [executeQQ|INSERT INTO "course_participant" ("course", "user", "registration", "state", "allocated") VALUES (#{transactionCourse}, #{transactionUser}, #{time}, #{CourseParticipantInactive False}, #{allocated}) ON CONFLICT DO NOTHING;|] + ensureParticipant _ = return () + runConduit $ getAuditLog .| C.mapM_ ensureParticipant + ) + ] diff --git a/src/Model/Types/Course.hs b/src/Model/Types/Course.hs index 4a1a08b3c..e7a991d29 100644 --- a/src/Model/Types/Course.hs +++ b/src/Model/Types/Course.hs @@ -10,6 +10,9 @@ module Model.Types.Course import Import.NoModel +import Model.Types.TH.PathPiece +import Utils.Lens.TH + data LecturerType = CourseLecturer | CourseAssistant deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -24,3 +27,20 @@ deriveJSON defaultOptions derivePersistFieldJSON ''LecturerType instance Hashable LecturerType + + +data CourseParticipantState + = CourseParticipantActive + | CourseParticipantInactive { courseParticipantNoShow :: Bool } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Hashable) + +makePrisms ''CourseParticipantState +makeLenses_ ''CourseParticipantState + +deriveFinite ''CourseParticipantState +finitePathPiece ''CourseParticipantState + ["active", "inactive", "no-show"] +pathPieceJSON ''CourseParticipantState +pathPieceJSONKey ''CourseParticipantState +derivePersistFieldPathPiece ''CourseParticipantState diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 78a88e909..6df3f8492 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -732,7 +732,94 @@ selectField' optMsg mkOpts = Field{..} #{optionDisplay opt} |] +radioField' :: ( Eq a + , RenderMessage (HandlerSite m) FormMessage + , MonadHandler m + ) + => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option + -> HandlerT (HandlerSite m) IO (OptionList a) + -> Field m a +-- ^ Like @radioField@, but with more control over the @Nothing@-Option, if Field is optional +radioField' optMsg mkOpts = Field{..} + where + fieldEnctype = UrlEncoded + fieldParse [] _ = return $ Right Nothing + fieldParse (s:_) _ + | s == "" = return $ Right Nothing + | otherwise = do + OptionList{olReadExternal} <- liftHandler mkOpts + return . maybe (Left . SomeMessage $ MsgInvalidEntry s) (Right . Just) $ olReadExternal s + + fieldView theId name attrs val isReq = do + OptionList{olOptions} <- liftHandler mkOpts + let + rendered = case val of + Left _ -> "" + Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions + + isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions + isSel (Just opt) = rendered == optionExternalValue opt + [whamlet| + $newline never +
+ $maybe optMsgM <- assertM (const $ not isReq) optMsg +