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

feat(course-participants): introduce CourseParticipantState

Browse Source 
BREAKING CHANGE: CourseParticipantState

Addresses #499
Fixes #371
This commit is contained in:
Gregor Kleen 2020-05-04 14:52:45 +02:00
parent 5a47688735
commit d5b65a1b06
39 changed files with 476 additions and 212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
frontend/src/app.sass
View File

@ -903,7 +903,7 @@ th, td
right: 5px right: 5px
top: 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 text-decoration: line-through
.result .result

2
frontend/src/services/http-client/http-client.js
View File

@ -49,7 +49,7 @@ export class HttpClient {
} }
_fetch(options) { _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) !== '//') 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); options.url = this._baseUrl + (this._baseUrl.substring(this._baseUrl.substring.length - 1) === '/' ? '' : '/') + options.url.substring(1,0);

84
frontend/src/utils/inputs/radio-group.sass
View File

@ -4,52 +4,52 @@
.radio-group .radio-group
display: flex display: flex
.radio .radio
position: relative position: relative
display: inline-block display: inline-block
[type='radio'] [type='radio']
position: fixed position: fixed
top: -1px top: -1px
left: -1px left: -1px
width: 1px width: 1px
height: 1px height: 1px
overflow: hidden overflow: hidden
label label
display: block display: block
height: 34px height: 34px
min-width: 42px min-width: 42px
line-height: 34px line-height: 34px
text-align: center text-align: center
padding: 0 13px padding: 0 13px
background-color: #f3f3f3 background-color: #f3f3f3
box-shadow: inset 2px 1px 2px 1px rgba(50, 50, 50, 0.05) box-shadow: inset 2px 1px 2px 1px rgba(50, 50, 50, 0.05)
color: var(--color-font) color: var(--color-font)
cursor: pointer cursor: pointer
\:checked + label \:checked + label
background-color: var(--color-primary) background-color: var(--color-primary)
color: var(--color-lightwhite) color: var(--color-lightwhite)
box-shadow: inset -2px -1px 2px 1px rgba(255, 255, 255, 0.15) box-shadow: inset -2px -1px 2px 1px rgba(255, 255, 255, 0.15)
\:focus + label \:focus + label
border-color: #3273dc border-color: #3273dc
box-shadow: 0 0 0.125em 0 rgba(50, 115, 220, 0.8) box-shadow: 0 0 0.125em 0 rgba(50, 115, 220, 0.8)
outline: 0 outline: 0
[disabled] + label [disabled] + label
pointer-events: none pointer-events: none
border: none border: none
opacity: 0.6 opacity: 0.6
filter: grayscale(1) filter: grayscale(1)
.radio:first-child .radio:first-child
label label
border-top-left-radius: 4px border-top-left-radius: 4px
border-bottom-left-radius: 4px border-bottom-left-radius: 4px
.radio:last-child .radio:last-child
label label
border-top-right-radius: 4px border-top-right-radius: 4px
border-bottom-right-radius: 4px border-bottom-right-radius: 4px

6
messages/uniworx/de-de-formal.msg
View File

@ -2512,4 +2512,8 @@ BearerTokenOverrideStartTip: Wird kein Startzeitpunkt angegeben, wird bei Verwen
FaqTitle: Häufig gestellte Fragen FaqTitle: Häufig gestellte Fragen
AdditionalFaqs: Weitere 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 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

1
models/courses.model
View File

@ -53,6 +53,7 @@ CourseParticipant -- course enrolement
registration UTCTime -- time of last enrolement for this course registration UTCTime -- time of last enrolement for this course
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
allocated AllocationId Maybe -- participant was centrally allocated allocated AllocationId Maybe -- participant was centrally allocated
state CourseParticipantState
UniqueParticipant user course UniqueParticipant user course
-- Replace the last two by the following, once an audit log is available -- 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 -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student

93
src/Foundation.hs
View File

@ -757,7 +757,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
registered <- case (mbc,mAuthId) of 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 _ -> return False
case mbc of case mbc of
(Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) (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 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.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId 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.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh 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 CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId
if | courseNewsParticipantsOnly -> do if | courseNewsParticipantsOnly -> do
uid <- hoistMaybe mAuthId 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 | otherwise
-> return Authorized -> return Authorized
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
isCourseParticipant tid ssh csh participant isCourseParticipant tid ssh csh participant False
unauthorizedI MsgUnauthorizedParticipant unauthorizedI MsgUnauthorizedParticipant
r -> $unsupportedAuthPredicate AuthParticipant r r -> $unsupportedAuthPredicate AuthParticipant r
where where
isCourseParticipant tid ssh csh participant = do isCourseParticipant tid ssh csh participant onlyActive = do
let let
authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB () authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from 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.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh 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 -- participant has at least one submission
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do when (not onlyActive) $
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.&&. course E.^. CourseTerm E.==. E.val tid E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is member of a submissionGroup -- participant is member of a submissionGroup
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do when (not onlyActive) $
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
E.&&. course E.^. CourseTerm E.==. E.val tid E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a sheet corrector -- participant is a sheet corrector
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet 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.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a tutorial user -- participant is a tutorial user
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do when (not onlyActive) $
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.&&. course E.^. CourseTerm E.==. E.val tid E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is tutor for this course -- participant is tutor for this course
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial 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.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant has an exam result for this course -- participant has an exam result for this course
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do when (not onlyActive) $
E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.&&. course E.^. CourseTerm E.==. E.val tid E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh 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 -- participant is registered for an exam for this course
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do when (not onlyActive) $
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.&&. course E.^. CourseTerm E.==. E.val tid E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return () return ()
tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of
@ -1225,7 +1232,7 @@ tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
return Authorized return Authorized
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh 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) guard $ NTop courseCapacity > NTop (Just registered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCapacity r r -> $unsupportedAuthPredicate AuthCapacity r
@ -1877,6 +1884,7 @@ siteLayout' headingOverride widget = do
isParticipant = E.exists . E.from $ \participant -> isParticipant = E.exists . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) 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 -> isLecturer = E.exists . E.from $ \lecturer ->
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) 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 E.&&. course E.^. CourseShorthand E.==. E.val csh
hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
void $ courseWhere course void $ courseWhere course
mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
in runDB $ mayRegister `or2M` hasParticipants in runDB $ mayRegister `or2M` hasParticipants

1
src/Handler/Allocation/Accept.hs
View File

@ -82,6 +82,7 @@ allocationAcceptForm aId = runMaybeT $ do
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
let participants = E.subSelectCount . E.from $ \courseParticipant -> let participants = E.subSelectCount . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (allocationCourse, course, participants) return (allocationCourse, course, participants)
let allocationCapacity = sumOf (folded . _2 . _entityVal . _courseCapacity . _Just) allocationCourses let allocationCapacity = sumOf (folded . _2 . _entityVal . _courseCapacity . _Just) allocationCourses

1
src/Handler/Allocation/Show.hs
View File

@ -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 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.on $ registration E.?. CourseParticipantCourse E.==. E.just (course E.^. CourseId)
E.&&. registration E.?. CourseParticipantUser E.==. E.val muid 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.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId)
E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid
E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId)

11
src/Handler/Allocation/Users.hs
View File

@ -45,6 +45,7 @@ queryAssignedCourses = queryAllocationUser . to queryAssignedCourses'
where queryAssignedCourses' allocationUser = E.subSelectCount . E.from $ \courseParticipant -> where queryAssignedCourses' allocationUser = E.subSelectCount . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. allocationUser E.^. AllocationUserUser E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. allocationUser E.^. AllocationUserUser
E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.just (allocationUser E.^. AllocationUserAllocation) 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 :: Getter UserTableExpr (E.SqlExpr (E.Value Int))
queryVetoedCourses = queryAllocationUser . to queryVetoedCourses' queryVetoedCourses = queryAllocationUser . to queryVetoedCourses'
@ -185,6 +186,9 @@ postAUsersR tid ssh ash = do
return ( course return ( course
, courseApplication E.^. CourseApplicationRatingPoints , courseApplication E.^. CourseApplicationRatingPoints
, E.just $ courseApplication E.^. CourseApplicationRatingVeto , 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 coursesModalVetoed = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseApplication) -> do
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
@ -195,6 +199,9 @@ postAUsersR tid ssh ash = do
return ( course return ( course
, E.nothing , E.nothing
, 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 coursesModalAssigned = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.on $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
@ -204,14 +211,16 @@ postAUsersR tid ssh ash = do
return ( course return ( course
, E.nothing , E.nothing
, E.nothing , E.nothing
, courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
) )
coursesModalNewAssigned = coursesModal $ \res -> E.from $ \course -> do coursesModalNewAssigned = coursesModal $ \res -> E.from $ \course -> do
E.where_ $ course E.^. CourseId `E.in_` E.valList (maybe [] otoList $ Map.lookup (res ^. resultUser . _entityKey) =<< allocMatching) E.where_ $ course E.^. CourseId `E.in_` E.valList (maybe [] otoList $ Map.lookup (res ^. resultUser . _entityKey) =<< allocMatching)
return ( course return ( course
, E.nothing , E.nothing
, 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' coursesModal courseSel = imapColonnade coursesModal'
where where
coursesModal' res innerCell = review dbCell . (innerCell ^. cellAttrs, ) $ do coursesModal' res innerCell = review dbCell . (innerCell ^. cellAttrs, ) $ do

2
src/Handler/Corrections.hs
View File

@ -1205,7 +1205,7 @@ assignHandler tid ssh csh cid assignSids = do
-- gather data -- gather data
(orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
nrParticipants <- count [CourseParticipantCourse ==. cid] nrParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList

6
src/Handler/Course/Application/List.hs
View File

@ -289,6 +289,7 @@ postCApplicationsR tid ssh csh = do
lift $ do lift $ do
E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser
E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid) 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 $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
@ -587,7 +588,7 @@ postCApplicationsR tid ssh csh = do
psValidator = def psValidator = def
& defaultSorting [SortAscBy "user-name"] & defaultSorting [SortAscBy "user-name"]
participants <- count [ CourseParticipantCourse ==. cid ] participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
let remainingCapacity = subtract participants <$> courseCapacity let remainingCapacity = subtract participants <$> courseCapacity
allocationsBounds' <- E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do allocationsBounds' <- E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do
@ -643,7 +644,7 @@ postCApplicationsR tid ssh csh = do
formResult acceptRes $ \(invMode, appsSecOrder) -> do formResult acceptRes $ \(invMode, appsSecOrder) -> do
runDBJobs $ do runDBJobs $ do
Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
participants <- count [ CourseParticipantCourse ==. cid ] participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
let openCapacity = subtract participants <$> courseCapacity let openCapacity = subtract participants <$> courseCapacity
applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do 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_ . E.not_ . E.exists . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (user, application) return (user, application)

1
src/Handler/Course/Communication.hs
View File

@ -40,6 +40,7 @@ postCCommR tid ssh csh = do
, E.from $ \(user `E.InnerJoin` participant) -> do , E.from $ \(user `E.InnerJoin` participant) -> do
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return user return user
) )
, ( RGCourseLecturers , ( RGCourseLecturers

2
src/Handler/Course/List.hs
View File

@ -61,11 +61,13 @@ type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int) course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
course2Participants (course `E.InnerJoin` _school) = E.subSelectCount . E.from $ \courseParticipant -> course2Participants (course `E.InnerJoin` _school) = E.subSelectCount . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId 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 :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid 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) ) makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
=> _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget

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

@ -42,6 +42,7 @@ instance IsInvitableJunction CourseParticipant where
{ jParticipantRegistration :: UTCTime { jParticipantRegistration :: UTCTime
, jParticipantField :: Maybe StudyFeaturesId , jParticipantField :: Maybe StudyFeaturesId
, jParticipantAllocated :: Maybe AllocationId , jParticipantAllocated :: Maybe AllocationId
, jParticipantState :: CourseParticipantState
} deriving (Eq, Ord, Read, Show, Generic, Typeable) } deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData CourseParticipant = InvDBDataParticipant data InvitationDBData CourseParticipant = InvDBDataParticipant
-- no data needed in DB to manage participant invitation -- no data needed in DB to manage participant invitation
@ -52,8 +53,8 @@ instance IsInvitableJunction CourseParticipant where
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso _InvitableJunction = iso
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated)) (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState))
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated) -> CourseParticipant{..}) (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState) -> CourseParticipant{..})
instance ToJSON (InvitableJunction CourseParticipant) where instance ToJSON (InvitableJunction CourseParticipant) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
@ -95,9 +96,10 @@ participantInvitationConfig = InvitationConfig{..}
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing (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 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 audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup
return res return res
@ -194,7 +196,7 @@ registerUser' :: CourseId
-> Maybe SubmissionGroupName -> Maybe SubmissionGroupName
-> WriterT AddParticipantsResult (YesodJobDB UniWorX) () -> WriterT AddParticipantsResult (YesodJobDB UniWorX) ()
registerUser' cid uid mbGrp = exceptT tell tell $ do 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 } throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
@ -210,12 +212,19 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do
= Nothing = Nothing
courseParticipantRegistration <- liftIO getCurrentTime courseParticipantRegistration <- liftIO getCurrentTime
void . lift . lift . insert $ CourseParticipant void . lift . lift $ upsert
{ courseParticipantCourse = cid CourseParticipant
, courseParticipantUser = uid { courseParticipantCourse = cid
, courseParticipantAllocated = Nothing , courseParticipantUser = uid
, .. , courseParticipantAllocated = Nothing
} , courseParticipantState = CourseParticipantActive
, ..
}
[ CourseParticipantRegistration =. courseParticipantRegistration
, CourseParticipantField =. courseParticipantField
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
lift . lift . audit $ TransactionCourseParticipantEdit cid uid lift . lift . audit $ TransactionCourseParticipantEdit cid uid
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid

20
src/Handler/Course/Register.hs
View File

@ -48,7 +48,7 @@ courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course
courseRegisterForm (Entity cid Course{..}) = liftHandler $ do courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
muid <- maybeAuthId muid <- maybeAuthId
(registration, application) <- runDB $ do (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] [] application <- fmap (listToMaybe =<<) . for muid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
return (registration, application) return (registration, application)
let btn | courseApplicationsRequired let btn | courseApplicationsRequired
@ -160,7 +160,7 @@ getCRegisterR tid ssh csh = do
Nothing -> addMessageI Info MsgLoginNecessary Nothing -> addMessageI Info MsgLoginNecessary
(Just uid) -> runDB $ do (Just uid) -> runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh 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 when (isNothing registration) $ addMessageI Warning MsgRegisterRetry
redirect $ CourseR tid ssh csh CShowR redirect $ CourseR tid ssh csh CShowR
@ -199,16 +199,22 @@ postCRegisterR tid ssh csh = do
= return $ Just () = return $ Just ()
mkRegistration = do mkRegistration = do
audit $ TransactionCourseParticipantEdit cid uid 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 case courseRegisterButton of
BtnCourseRegister -> runDB $ do BtnCourseRegister -> runDB $ do
regOk <- (\app reg -> (,) <$> app <*> reg) <$> mkApplication <*> mkRegistration regOk <- (\app reg -> (, reg) <$> app) <$> mkApplication <*> mkRegistration
case regOk of case regOk of
Nothing -> transactionUndo Nothing -> transactionUndo
Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
BtnCourseDeregister -> runDB $ do 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 forM_ part $ \(Entity _partId CourseParticipant{..}) -> do
when (is _Just courseParticipantAllocated) $ do when (is _Just courseParticipantAllocated) $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
@ -243,9 +249,9 @@ deleteApplicationFiles appId = do
deregisterParticipant :: UserId -> CourseId -> DB () deregisterParticipant :: UserId -> CourseId -> DB ()
deregisterParticipant uid cid = do deregisterParticipant uid cid = do
deleteApplications uid cid 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 forM_ part $ \(Entity partId CourseParticipant{..}) -> do
delete $ partId update partId [CourseParticipantState =. CourseParticipantInactive False]
audit $ TransactionCourseParticipantDeleted cid uid audit $ TransactionCourseParticipantDeleted cid uid
examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do

2
src/Handler/Course/Show.hs
View File

@ -32,6 +32,7 @@ getCShowR tid ssh csh = do
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser 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.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
E.where_ $ course E.^. CourseTerm E.==. E.val tid E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
@ -40,6 +41,7 @@ getCShowR tid ssh csh = do
let numParticipants :: E.SqlExpr (E.Value Int) let numParticipants :: E.SqlExpr (E.Value Int)
numParticipants = E.subSelectCount . E.from $ \part -> numParticipants = E.subSelectCount . E.from $ \part ->
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. part E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (course,school E.^. SchoolName, numParticipants, participant) return (course,school E.^. SchoolName, numParticipants, participant)
staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId

27
src/Handler/Course/User.hs
View File

@ -55,7 +55,7 @@ postCUserR tid ssh csh uCId = do
uid <- decrypt uCId uid <- decrypt uCId
course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
user <- get404 uid user <- get404 uid
registered <- existsBy $ UniqueParticipant uid cid registered <- exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ]
return (course, Entity uid user, registered) return (course, Entity uid user, registered)
@ -90,7 +90,7 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
currentRoute <- MaybeT getCurrentRoute currentRoute <- MaybeT getCurrentRoute
(mRegistration, studies) <- lift . runDB $ do (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 studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
@ -167,17 +167,18 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
= Just featId = Just featId
| otherwise | otherwise
= Nothing = Nothing
pId <- lift . runDBJobs $ do lift . runDBJobs $ do
pId <- insertUnique $ CourseParticipant cid uid now field Nothing void $ upsert
when (is _Just pId) $ do (CourseParticipant cid uid now field Nothing CourseParticipantActive)
queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid [ CourseParticipantRegistration =. now
audit $ TransactionCourseParticipantEdit cid uid , CourseParticipantField =. field
return pId , CourseParticipantAllocated =. Nothing
case pId of , CourseParticipantState =. CourseParticipantActive
Just _ -> do ]
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
redirect currentRoute audit $ TransactionCourseParticipantEdit cid uid
Nothing -> invalidArgs ["User already registered"] addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
redirect currentRoute
_other -> error "Invalid @regButton@" _other -> error "Invalid @regButton@"
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime

34
src/Handler/Course/Users.hs
View File

@ -71,7 +71,7 @@ querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 4 4)
userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User) 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))) , E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
, StudyFeaturesDescription' , StudyFeaturesDescription'
, E.SqlExpr (Maybe (Entity SubmissionGroup)) , 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.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid 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 type UserTableData = DBRow ( Entity User
, UTCTime , Entity CourseParticipant
, Maybe CourseUserNoteId , Maybe CourseUserNoteId
, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) , (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
, ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
@ -104,8 +104,11 @@ instance HasEntity UserTableData User where
instance HasUser UserTableData where instance HasUser UserTableData where
hasUser = _dbrOutput . _1 . _entityVal hasUser = _dbrOutput . _1 . _entityVal
_userTableParticipant :: Lens' UserTableData (Entity CourseParticipant)
_userTableParticipant = _dbrOutput . _2
_userTableRegistration :: Lens' UserTableData UTCTime _userTableRegistration :: Lens' UserTableData UTCTime
_userTableRegistration = _dbrOutput . _2 _userTableRegistration = _userTableParticipant . _entityVal . _courseParticipantRegistration
_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId) _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
_userTableNote = _dbrOutput . _3 _userTableNote = _dbrOutput . _3
@ -326,7 +329,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q) dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
dbtRowKey = queryUser >>> (E.^. UserId) 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 ] [] tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] [] exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] []
let let
@ -334,7 +337,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials 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' 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 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 dbtColonnade = colChoices
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header [ 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-registration", error "TODO") -- TODO
-- , ("course-user-note", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO
, single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) , 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 where single = uncurry Map.singleton
dbtFilterUI mPrev = mconcat $ dbtFilterUI mPrev = mconcat $
[ fltrUserNameEmailUI mPrev [ prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt (courseParticipantStateIsActiveField . Just $ SomeMessage MsgNoFilter) (fslI MsgCourseParticipantStateIsActiveFilter)
, fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev , fltrUserMatriclenrUI mPrev
] ++ ] ++
[ fltrUserSexUI mPrev | showSex ] ++ [ fltrUserSexUI mPrev | showSex ] ++
@ -505,6 +510,7 @@ courseUserDeregisterForm cid = wFormToAForm $ do
allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant -> allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated) E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated)
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
if | allocated -> do if | allocated -> do
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip
fmap CourseUserDeregisterData <$> optionalActionW (apreq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True) 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 hasSubmissionGroups colUserSubmissionGroup
, guardOn hasTutorials $ colUserTutorials tid ssh csh , guardOn hasTutorials $ colUserTutorials tid ssh csh
, guardOn hasExams $ colUserExams 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 , pure $ colUserComment tid ssh csh
] ]
psValidator = def & defaultSortingByName psValidator = def & defaultSortingByName
& defaultFilter (singletonMap "active" [toPathPiece True])
hasExams = not $ null exams hasExams = not $ null exams
examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId)) examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
examOccActs = examOccurrencesPerExam examOccActs = examOccurrencesPerExam
@ -587,7 +594,7 @@ postCUsersR tid ssh csh = do
| otherwise | otherwise
-> mempty -> mempty
] ]
numParticipants <- count [CourseParticipantCourse ==. cid] numParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True) table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True)
return (ent, numParticipants, table) return (ent, numParticipants, table)
formResult participantRes $ \case formResult participantRes $ \case
@ -597,7 +604,7 @@ postCUsersR tid ssh csh = do
(CourseUserDeregisterData{..}, selectedUsers) -> do (CourseUserDeregisterData{..}, selectedUsers) -> do
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
now <- liftIO getCurrentTime 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 lift $ deregisterParticipant courseParticipantUser courseParticipantCourse
case deregisterReason of case deregisterReason of
Just reason Just reason
@ -613,10 +620,11 @@ postCUsersR tid ssh csh = do
addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
redirect $ CourseR tid ssh csh CUsersR redirect $ CourseR tid ssh csh CUsersR
(CourseUserRegisterExamData{..}, selectedUsers) -> do (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 now <- liftIO getCurrentTime
let (exam, mOccurrence) = registerExam let (exam, mOccurrence) = registerExam
mExamReg <- insertUnique ExamRegistration mExamReg <- lift $ insertUnique ExamRegistration
{ examRegistrationExam = exam { examRegistrationExam = exam
, examRegistrationUser = uid , examRegistrationUser = uid
, examRegistrationOccurrence = mOccurrence , examRegistrationOccurrence = mOccurrence
@ -624,7 +632,7 @@ postCUsersR tid ssh csh = do
} }
case mExamReg of case mExamReg of
Just _ -> do Just _ -> do
audit $ TransactionExamRegister exam uid lift . audit $ TransactionExamRegister exam uid
return 1 return 1
Nothing -> Nothing ->
return mempty return mempty

23
src/Handler/Exam/AddUser.hs
View File

@ -127,7 +127,7 @@ postEAddUserR tid ssh csh examn = do
whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $ whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $
throwError $ mempty { aurAlreadyRegistered = pure userEmail } 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 lift $ lift examRegister
throwError $ mempty { aurSuccess = pure userEmail } throwError $ mempty { aurSuccess = pure userEmail }
@ -142,13 +142,20 @@ postEAddUserR tid ssh csh examn = do
| [f] <- features = Just f | [f] <- features = Just f
| otherwise = Nothing | otherwise = Nothing
lift . lift . insert_ $ CourseParticipant lift . lift . void $ upsert
{ courseParticipantCourse = cid CourseParticipant
, courseParticipantUser = uid { courseParticipantCourse = cid
, courseParticipantRegistration = now , courseParticipantUser = uid
, courseParticipantAllocated = Nothing , courseParticipantRegistration = now
, .. , courseParticipantAllocated = Nothing
} , courseParticipantState = CourseParticipantActive
, ..
}
[ CourseParticipantRegistration =. now
, CourseParticipantAllocated =. Nothing
, CourseParticipantField =. courseParticipantField
, CourseParticipantState =. CourseParticipantActive
]
lift . lift . audit $ TransactionCourseParticipantEdit cid uid lift . lift . audit $ TransactionCourseParticipantEdit cid uid
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
lift $ lift examRegister lift $ lift examRegister

10
src/Handler/Exam/RegistrationInvite.hs
View File

@ -90,7 +90,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
return InvitationTokenConfig{..} return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do 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 now <- liftIO getCurrentTime
case (isRegistered, invDBExamRegistrationCourseRegister) of case (isRegistered, invDBExamRegistrationCourseRegister) of
@ -101,7 +101,13 @@ examRegistrationInvitationConfig = InvitationConfig{..}
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
whenIsJust mField $ \cpField -> 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 queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser

24
src/Handler/Exam/Users.hs
View File

@ -471,6 +471,7 @@ postEUsersR tid ssh csh examn = do
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) 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.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
@ -758,13 +759,20 @@ postEUsersR tid ssh csh examn = do
C.mapM_ $ \case C.mapM_ $ \case
ExamUserCsvCourseRegisterData{..} -> do ExamUserCsvCourseRegisterData{..} -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
insert_ CourseParticipant void $ upsert
{ courseParticipantCourse = examCourse CourseParticipant
, courseParticipantUser = examUserCsvActUser { courseParticipantCourse = examCourse
, courseParticipantRegistration = now , courseParticipantUser = examUserCsvActUser
, courseParticipantField = examUserCsvActCourseField , courseParticipantRegistration = now
, courseParticipantAllocated = Nothing , courseParticipantField = examUserCsvActCourseField
} , courseParticipantAllocated = Nothing
, courseParticipantState = CourseParticipantActive
}
[ CourseParticipantRegistration =. now
, CourseParticipantField =. examUserCsvActCourseField
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
insert_ ExamRegistration insert_ ExamRegistration
@ -971,7 +979,7 @@ postEUsersR tid ssh csh examn = do
, GuessUserFirstName <$> csvEUserFirstName , GuessUserFirstName <$> csvEUserFirstName
] ]
pid <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria 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 -> DB (Maybe ExamOccurrenceId)
lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do

1
src/Handler/ExamOffice/Exam.hs
View File

@ -261,6 +261,7 @@ postEGradesR tid ssh csh examn = do
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) 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.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence) E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence)
E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId) E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId)

6
src/Handler/News.hs
View File

@ -111,7 +111,8 @@ newsUpcomingSheets uid = do
E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom) E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom)
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid 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 return
( course E.^. CourseTerm ( course E.^. CourseTerm
@ -224,7 +225,8 @@ newsUpcomingExams uid = do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ E.exists $ E.from $ \participant -> E.where_ $ E.exists $ E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid 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) let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight)
E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now) E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now)
E.&&. E.isNothing (register E.?. ExamRegistrationId) E.&&. E.isNothing (register E.?. ExamRegistrationId)

6
src/Handler/Participants.hs
View File

@ -46,6 +46,7 @@ getParticipantsListR = do
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
E.&&. course E.^. CourseSchool E.==. school E.^. SchoolId E.&&. course E.^. CourseSchool E.==. school E.^. SchoolId
E.where_ $ participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (school E.^. SchoolId, term E.^. TermId) 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.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.where_ $ participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (course E.^. CourseName, user E.^. UserEmail) return (course E.^. CourseName, user E.^. UserEmail)
@ -103,11 +105,13 @@ postParticipantsIntersectR = do
E.where_ . E.exists . E.from $ \courseParticipant -> E.where_ . E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val lCid 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_ . E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val uCid 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)) 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 let intersections' = Map.union intersections selfIntersections
courses <- sortOn (view $ _entityVal . $(multifocusL 3) _courseTerm _courseSchool _courseShorthand) <$> forM (Set.toList cids) getEntity404 courses <- sortOn (view $ _entityVal . $(multifocusL 3) _courseTerm _courseSchool _courseShorthand) <$> forM (Set.toList cids) getEntity404
return (courses, intersections') return (courses, intersections')

2
src/Handler/Profile.hs
View File

@ -159,6 +159,7 @@ notificationForm template = wFormToAForm $ do
, NTKCourseParticipant <- nt , NTKCourseParticipant <- nt
= fmap not . E.selectExists . E.from $ \courseParticipant -> = fmap not . E.selectExists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
| Just uid <- mbUid | Just uid <- mbUid
, NTKSubmissionUser <- nt , NTKSubmissionUser <- nt
= fmap not . E.selectExists . E.from $ \submissionUser -> = fmap not . E.selectExists . E.from $ \submissionUser ->
@ -454,6 +455,7 @@ mkEnrolledCoursesTable =
, dbtSQLQuery = \(course `E.InnerJoin` participant) -> do , dbtSQLQuery = \(course `E.InnerJoin` participant) -> do
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (course, participant E.^. CourseParticipantRegistration) return (course, participant E.^. CourseParticipantRegistration)
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
, dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue , dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue

6
src/Handler/Submission.hs
View File

@ -152,6 +152,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return user return user
previousCoSubmittors :: UserId -> E.SqlQuery (E.SqlExpr (Entity 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_ . E.exists . E.from $ \submissionUser' ->
E.where_ $ submissionUser' E.^. SubmissionUserUser E.==. E.val uid E.where_ $ submissionUser' E.^. SubmissionUserUser E.==. E.val uid
E.&&. submissionUser' E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId 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] E.orderBy [E.asc $ user E.^. UserEmail]
return user return user
@ -452,6 +457,7 @@ submissionHelper tid ssh csh shn mcid = do
isParticipant = E.exists . E.from $ \courseParticipant -> do isParticipant = E.exists . E.from $ \courseParticipant -> do
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse 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 hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId

31
src/Handler/Utils/Allocation.hs
View File

@ -92,11 +92,20 @@ computeAllocation :: Entity Allocation
, Seq MatchingLogRun , Seq MatchingLogRun
) )
computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = do computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = do
allocations <- selectList [ CourseParticipantAllocated ==. Just allocId ] [] allocations <- selectList [ CourseParticipantAllocated ==. Just allocId, CourseParticipantState ==. CourseParticipantActive ] []
let allocations' = allocations let allocations' = allocations
& map ((, Sum 1) . courseParticipantUser . entityVal) & map ((, Sum 1) . courseParticipantUser . entityVal)
& Map.fromListWith (<>) & 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 ] [] users' <- selectList [ AllocationUserAllocation ==. allocId ] []
let users'' = users' let users'' = users'
@ -105,7 +114,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d
totalCourses <- lift $ allocationUserTotalCourses . entityVal totalCourses <- lift $ allocationUserTotalCourses . entityVal
priority <- MaybeT $ allocationUserPriority . 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 guard $ totalCourses > allocated
@ -121,6 +130,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d
let participants = E.subSelectCount . E.from $ \participant -> do let participants = E.subSelectCount . E.from $ \participant -> do
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId 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_ . E.not_ . E.exists . E.from $ \lecturer ->
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser
@ -145,12 +155,14 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d
allocStarted <- lift $ allocationStarted allocId allocStarted <- lift $ allocationStarted allocId
whenIsJust allocStarted $ \allocStarted' -> do 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 $ whenM partDeleted $
tellExcluded MatchingExcludedParticipationExisted tellExcluded MatchingExcludedParticipationExisted
let partExists :: StateT _ DB Bool let partExists :: StateT _ DB Bool
partExists = lift $ exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser ] partExists = lift $ exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser, CourseParticipantState ==. CourseParticipantActive ]
whenM partExists $ whenM partExists $
tellExcluded MatchingExcludedParticipationExists tellExcluded MatchingExcludedParticipationExists
@ -233,7 +245,14 @@ doAllocation :: AllocationId
doAllocation allocId now regs = doAllocation allocId now regs =
forM_ regs $ \(uid, cid) -> do forM_ regs $ \(uid, cid) -> do
mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] [] 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 :: Seq MatchingLogRun -> Text
ppMatchingLog = unlines . map prettyRun . otoList ppMatchingLog = unlines . map prettyRun . otoList

48
src/Handler/Utils/Form.hs
View File

@ -1294,24 +1294,20 @@ boolField :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
) )
=> Maybe (SomeMessage UniWorX) -> Field m Bool => Maybe (SomeMessage UniWorX) -> Field m Bool
boolField mkNone = Field boolField mkNone = radioGroupField mkNone $ do
{ fieldParse = \e _ -> return $ boolParser e mr <- getMessageRender
, fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool") return OptionList
, fieldEnctype = UrlEncoded { olOptions = [ Option (mr MsgBoolNo ) False "no"
} , Option (mr MsgBoolYes) True "yes"
where ]
boolParser [] = Right Nothing , olReadExternal = \case
boolParser (x:_) = case x of "yes" -> Just True
"" -> Right Nothing "on" -> Just True
"none" -> Right Nothing "no" -> Just False
"yes" -> Right $ Just True "true" -> Just True
"on" -> Right $ Just True "false" -> Just False
"no" -> Right $ Just False _other -> Nothing
"true" -> Right $ Just True }
"false" -> Right $ Just False
t -> Left $ SomeMessage $ MsgInvalidBool t
showVal = either $ const False
@ -1859,3 +1855,19 @@ labeledCheckBoxView :: Widget
labeledCheckBoxView label theId name attrs val isReq = $(widgetFile "widgets/fields/labeled-checkbox") labeledCheckBoxView label theId name attrs val isReq = $(widgetFile "widgets/fields/labeled-checkbox")
where where
checkBoxView = fieldView (checkBoxField :: Field Handler Bool) theId name attrs val isReq 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

25
src/Handler/Utils/Table/Pagination.hs
View File

@ -333,6 +333,14 @@ piIsUnset PaginationInput{..} = and
, isNothing piPage , 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 data DBCsvActionMode = DBCsvActionNew | DBCsvActionExisting | DBCsvActionMissing
deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, Typeable) 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") <*> iopt intField (wIdent "page")
let prevPi let prevPi
| FormSuccess pi <- piPreviousRes <|> piInput = views _2 psToPi . runPSValidator dbtable . formResultToMaybe $ piPreviousRes <|> piInput
= pi
| otherwise
= def
referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
@ -901,8 +906,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
return (filterRes', pagesizeRes') return (filterRes', pagesizeRes')
let let
piResult = (\fSettings -> prevPi & _piFilter .~ Just fSettings) <$> filterRes piResult = (prevPi &) . (_piFilter ?~) <$> filterRes
<|> (\ps -> prevPi & _piLimit .~ Just ps) <$> pagesizeRes <|> (prevPi &) . (_piLimit ?~) <$> pagesizeRes
<|> piPreviousRes <|> piPreviousRes
<|> piInput <|> piInput
@ -945,7 +950,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
| otherwise | otherwise
= True = 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 DBTCsvEncode{..}
| Just (cloneIso -> noExportData') <- dbtCsvNoExportData | Just (cloneIso -> noExportData') <- dbtCsvNoExportData
-> toDyn . view (noExportData' . from noExportData') <$> dbtCsvExportForm -> toDyn . view (noExportData' . from noExportData') <$> dbtCsvExportForm
@ -1017,8 +1022,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
res <- dbtSQLQuery t res <- dbtSQLQuery t
E.orderBy $ sortSql t E.orderBy $ sortSql t
case csvMode of case csvMode of
FormSuccess DBCsvExport{} -> return () -- FormSuccess DBCsvExport{} -> return ()
FormSuccess DBCsvImport{} -> 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 _other -> do
case previousKeys of case previousKeys of
Nothing Nothing
@ -1310,7 +1315,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
csvWdgt = $(widgetFile "table/csv-transcode") 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 $ dbInvalidateResult' = foldr (<=<) return . catMaybes $
[ do [ do

6
src/Jobs/Handler/QueueNotification.hs
View File

@ -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.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 $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser 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 E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user return user
determineNotificationCandidates NotificationSheetSoonInactive{..} determineNotificationCandidates NotificationSheetSoonInactive{..}
= E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do = 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 $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser 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 E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user return user
determineNotificationCandidates NotificationSheetInactive{..} determineNotificationCandidates NotificationSheetInactive{..}
@ -82,6 +84,7 @@ determineNotificationCandidates NotificationExamRegistrationActive{..} =
E.where_ . E.not_ . E.exists . E.from $ \examRegistration -> E.where_ . E.not_ . E.exists . E.from $ \examRegistration ->
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val nExam E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val nExam
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return user return user
determineNotificationCandidates NotificationExamRegistrationSoonInactive{..} = determineNotificationCandidates NotificationExamRegistrationSoonInactive{..} =
E.select . E.from $ \(exam `E.InnerJoin` courseParticipant `E.InnerJoin` user) -> do 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_ . E.not_ . E.exists . E.from $ \examRegistration ->
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val nExam E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val nExam
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return user return user
determineNotificationCandidates NotificationExamDeregistrationSoonInactive{..} = determineNotificationCandidates NotificationExamDeregistrationSoonInactive{..} =
E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do 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.where_ $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
E.&&. participant E.^. CourseParticipantRegistration E.>. E.val t 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 hasAllocations t = E.exists . E.from $ \(lecturer `E.InnerJoin` participant) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.&&. lecturer E.^. LecturerCourse E.==. participant E.^. CourseParticipantCourse E.&&. lecturer E.^. LecturerCourse E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
E.&&. participant E.^. CourseParticipantRegistration E.>. E.val t E.&&. participant E.^. CourseParticipantRegistration E.>. E.val t
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
case lastExec of case lastExec of
Nothing -> E.where_ $ isStudent E.||. isLecturer Nothing -> E.where_ $ isStudent E.||. isLecturer
Just t -> E.where_ $ wasAllocated t E.||. hasAllocations t Just t -> E.where_ $ wasAllocated t E.||. hasAllocations t

3
src/Jobs/Handler/SendNotification/Allocation.hs
View File

@ -167,9 +167,11 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi
allocatedCount = E.subSelectCount . E.from $ \participant -> allocatedCount = E.subSelectCount . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) 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) let participantCount :: E.SqlExpr (E.Value Int64)
participantCount = E.subSelectCount . E.from $ \participant -> participantCount = E.subSelectCount . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (course, allocatedCount, participantCount) return (course, allocatedCount, participantCount)
let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value allocCount, E.Value partCount) -> SomeMessage $ if let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value allocCount, E.Value partCount) -> SomeMessage $ if
| allocCount == partCount -> MsgAllocationResultLecturerAll courseShorthand allocCount | allocCount == partCount -> MsgAllocationResultLecturerAll courseShorthand allocCount
@ -183,6 +185,7 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi
E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
E.&&. participant E.^. CourseParticipantUser E.==. E.val jRecipient E.&&. participant E.^. CourseParticipantUser E.==. E.val jRecipient
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return course return course
let participantResults = case participantResults' of let participantResults = case participantResults' of
[] | doParticipantResults -> Just [] [] | doParticipantResults -> Just []

30
src/Model/Migration.hs
View File

@ -34,6 +34,8 @@ import qualified Net.IPv6 as IPv6
import qualified Data.Char as Char import qualified Data.Char as Char
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Aeson as Aeson
import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage) import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage)
-- Database versions must follow https://pvp.haskell.org: -- Database versions must follow https://pvp.haskell.org:
@ -639,6 +641,34 @@ customMigrations = Map.fromListWith (>>)
whenM (tableExists "submission_group_edit") $ whenM (tableExists "submission_group_edit") $
tableDropEmpty "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
)
] ]

20
src/Model/Types/Course.hs
View File

@ -10,6 +10,9 @@ module Model.Types.Course
import Import.NoModel import Import.NoModel
import Model.Types.TH.PathPiece
import Utils.Lens.TH
data LecturerType = CourseLecturer | CourseAssistant data LecturerType = CourseLecturer | CourseAssistant
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@ -24,3 +27,20 @@ deriveJSON defaultOptions
derivePersistFieldJSON ''LecturerType derivePersistFieldJSON ''LecturerType
instance Hashable 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

87
src/Utils/Form.hs
View File

@ -732,7 +732,94 @@ selectField' optMsg mkOpts = Field{..}
#{optionDisplay opt} #{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
<div ##{theId}>
$maybe optMsgM <- assertM (const $ not isReq) optMsg
<label .radio for=#{theId}->
<div>
<input id=#{theId}- type=radio name=#{name} value="" :isSel Nothing:checked *{attrs}>
_{optMsgM}
$forall opt <- olOptions
<label .radio for=#{theId}-#{optionExternalValue opt}>
<div>
<input id=#{theId}-#{optionExternalValue opt} type=radio name=#{name} value=#{optionExternalValue opt} :isSel (Just opt):checked *{attrs}>
#{optionDisplay opt}
|]
radioGroupField :: ( 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
radioGroupField 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
<div .radio-group ##{theId}>
$maybe optMsgM <- assertM (const $ not isReq) optMsg
<div .radio>
<input id=#{theId}- type=radio name=#{name} value="" :isSel Nothing:checked *{attrs}>
<label for=#{theId}->
_{optMsgM}
$forall opt <- olOptions
<div .radio>
<input id=#{theId}-#{optionExternalValue opt} type=radio name=#{name} value=#{optionExternalValue opt} :isSel (Just opt):checked *{attrs}>
<label for=#{theId}-#{optionExternalValue opt}>
#{optionDisplay opt}
|]
----------- -----------
-- Forms -- -- Forms --
----------- -----------

1
src/Utils/Lens.hs
View File

@ -200,6 +200,7 @@ makeLenses_ ''ExamOccurrence
makePrisms ''AuthenticationMode makePrisms ''AuthenticationMode
makeLenses_ ''CourseUserNote makeLenses_ ''CourseUserNote
makeLenses_ ''CourseParticipant
makeLenses_ ''CourseApplication makeLenses_ ''CourseApplication

4
templates/table/cell/allocation-courses.hamlet
View File

@ -1,7 +1,7 @@
$newline never $newline never
<ul> <ul>
$forall (Entity _ Course{courseTerm, courseSchool, courseName}, E.Value mbRating, E.Value mbVeto) <- courses $forall (Entity _ Course{courseTerm, courseSchool, courseName}, E.Value mbRating, E.Value mbVeto, E.Value active) <- courses
<li> <li :not active:.allocation-course--inactive>
#{courseTerm} - #{courseSchool} - #{courseName} #{courseTerm} - #{courseSchool} - #{courseName}
$case (mbRating, mbVeto) $case (mbRating, mbVeto)
$of (_, Just True) $of (_, Just True)

1
templates/table/layout.hamlet
View File

@ -1,4 +1,5 @@
$newline never $newline never
^{csvWdgt}
$if null rows && (dbsEmptyStyle == DBESNoHeading) $if null rows && (dbsEmptyStyle == DBESNoHeading)
_{dbsEmptyMessage} _{dbsEmptyMessage}
$else $else

15
templates/widgets/fields/bool.hamlet
View File

@ -1,15 +0,0 @@
$newline never
<div .radio-group>
$if not isReq
$maybe noneMsg <- mkNone
<div .radio>
<input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked>
<label for=#{theId}-none>_{noneMsg}
<div .radio>
<input id=#{theId}-yes *{attrs} type=radio name=#{name} value=yes :showVal id val:checked>
<label for=#{theId}-yes>_{MsgBoolYes}
<div .radio>
<input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked>
<label for=#{theId}-no>_{MsgBoolNo}

13
test/Database/Fill.hs
View File

@ -609,11 +609,14 @@ fillDb = do
, sheetAnonymousCorrection = True , sheetAnonymousCorrection = True
} }
insert_ $ SheetEdit gkleen now keine insert_ $ SheetEdit gkleen now keine
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing) void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing CourseParticipantActive)
[(fhamann , Nothing) [(fhamann , Nothing)
,(maxMuster , Just sfMMs) ,(maxMuster , Just sfMMs)
,(tinaTester, Just sfTTc) ,(tinaTester, Just sfTTc)
] ]
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing $ CourseParticipantInactive False)
[(svaupel, Nothing)
]
examFFP <- insert' $ Exam examFFP <- insert' $ Exam
{ examCourse = ffp { examCourse = ffp
@ -733,7 +736,7 @@ fillDb = do
insert_ $ CourseEdit jost now pmo insert_ $ CourseEdit jost now pmo
void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ DegreeCourse pmo sdBsc sdInf
void . insert $ Lecturer jost pmo CourseAssistant void . insert $ Lecturer jost pmo CourseAssistant
void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf Nothing) void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf Nothing CourseParticipantActive)
[(fhamann , Nothing) [(fhamann , Nothing)
,(maxMuster , Just sfMMp) ,(maxMuster , Just sfMMp)
,(tinaTester, Just sfTTb) ,(tinaTester, Just sfTTb)
@ -1020,7 +1023,7 @@ fillDb = do
void . insert' $ Lecturer gkleen bs CourseLecturer void . insert' $ Lecturer gkleen bs CourseLecturer
void . insertMany $ do void . insertMany $ do
uid <- take 1024 manyUsers uid <- take 1024 manyUsers
return $ CourseParticipant bs uid now Nothing Nothing return $ CourseParticipant bs uid now Nothing Nothing CourseParticipantActive
forM_ [1..14] $ \shNr -> do forM_ [1..14] $ \shNr -> do
shId <- insert Sheet shId <- insert Sheet
{ sheetCourse = bs { sheetCourse = bs
@ -1090,7 +1093,7 @@ fillDb = do
participants <- getRandomR (0, 50) participants <- getRandomR (0, 50)
manyUsers' <- shuffleM $ take 1024 manyUsers manyUsers' <- shuffleM $ take 1024 manyUsers
forM_ (take participants manyUsers') $ \uid -> forM_ (take participants manyUsers') $ \uid ->
void . insert $ CourseParticipant cid uid now Nothing Nothing void . insert $ CourseParticipant cid uid now Nothing Nothing CourseParticipantActive
aSeedBig <- liftIO $ getRandomBytes 40 aSeedBig <- liftIO $ getRandomBytes 40
bigAlloc <- insert' Allocation bigAlloc <- insert' Allocation
@ -1113,7 +1116,7 @@ fillDb = do
, allocationMatchingSeed = aSeedBig , allocationMatchingSeed = aSeedBig
} }
bigAllocCourses <- forM ([1..40] :: [Int]) $ \n -> do bigAllocCourses <- forM ([1..40] :: [Int]) $ \n -> do
csh <- pack . take 3 <$> getRandomRs ('A', 'Z') csh <- ("ZA-" <>) . pack . take 3 <$> getRandomRs ('A', 'Z')
cap <- getRandomR (10,50) cap <- getRandomR (10,50)