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