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

feat(course-visibility): allow access for exam correctors

Browse Source
This commit is contained in:
Sarah Vaupel 2020-08-08 12:54:37 +02:00
parent 16ad72d876
commit dfa70ee7fe
4 changed files with 37 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
routes
View File

@ -124,7 +124,7 @@
/course/ CourseListR GET !free /course/ CourseListR GET !free
!/course/new CourseNewR GET POST !lecturer !/course/new CourseNewR GET POST !lecturer
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !tutor !corrector !course-registered !course-time !evaluation !exam-office !allocation-admin / CShowR GET !tutor !corrector !exam-corrector !course-registered !course-time !evaluation !exam-office !allocation-admin
/favourite CFavouriteR POST /favourite CFavouriteR POST
/register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬course-registeredANDcourse-time !timeANDallocation-timeAND¬exam-resultANDcourse-registered !lecturerANDallocation-time /register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬course-registeredANDcourse-time !timeANDallocation-timeAND¬exam-resultANDcourse-registered !lecturerANDallocation-time
/register-template CRegisterTemplateR GET !course-time /register-template CRegisterTemplateR GET !course-time
@ -184,10 +184,10 @@
/register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered
/communication TCommR GET POST !tutor /communication TCommR GET POST !tutor
/tutor-invite TInviteR GET POST !tutorANDtutor-control /tutor-invite TInviteR GET POST !tutorANDtutor-control
/exams CExamListR GET !tutor !corrector !course-registered !course-time !exam-office /exams CExamListR GET !tutor !corrector !exam-corrector !course-registered !course-time !exam-office
/exams/new CExamNewR GET POST /exams/new CExamNewR GET POST
/exams/#ExamName ExamR: /exams/#ExamName ExamR:
/show EShowR GET !timeANDtutor !timeANDcorrector !timeANDcourse-registered !timeANDcourse-time !exam-office /show EShowR GET !timeANDtutor !timeANDcorrector !timeANDexam-corrector !timeANDcourse-registered !timeANDcourse-time !exam-office
/edit EEditR GET POST /edit EEditR GET POST
/corrector-invite ECInviteR GET POST /corrector-invite ECInviteR GET POST
/users EUsersR GET POST /users EUsersR GET POST

21
src/Foundation.hs
View File

@ -674,12 +674,23 @@ tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
E.&&. examCorrector E.^. ExamCorrectorUser E.==. E.val authId
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
E.where_ $ course E.^. CourseTerm E.==. E.val tid E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId
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.&&. exam E.^. ExamName E.==. E.val examn E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. exam E.^. ExamName E.==. E.val examn
guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
return Authorized
CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthExamCorrector r r -> $unsupportedAuthPredicate AuthExamCorrector r

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

@ -154,7 +154,8 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
E.||. courseIsVisible now course Nothing E.||. courseIsVisible now course Nothing
E.||. isCourseLecturer muid ata (course E.^. CourseId) E.||. isCourseLecturer muid ata (course E.^. CourseId)
E.||. isCourseTutor muid ata (course E.^. CourseId) E.||. isCourseTutor muid ata (course E.^. CourseId)
E.||. isCourseCorrector muid ata (course E.^. CourseId) E.||. isCourseSheetCorrector muid ata (course E.^. CourseId)
E.||. isCourseExamCorrector muid ata (course E.^. CourseId)
) )
when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $ when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $

24
src/Utils/Course.hs
View File

@ -1,7 +1,7 @@
module Utils.Course module Utils.Course
( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse' ( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse'
, isSchoolAdmin, isSchoolAdminLike , isSchoolAdmin, isSchoolAdminLike
, isCourseLecturer, isCourseTutor, isCourseCorrector , isCourseLecturer, isCourseTutor, isCourseSheetCorrector, isCourseExamCorrector
, isCourseParticipant, isCourseApplicant , isCourseParticipant, isCourseApplicant
, isCourseAssociated , isCourseAssociated
, courseIsVisible, courseIsVisible' , courseIsVisible, courseIsVisible'
@ -80,13 +80,20 @@ isCourseTutor muid AuthTagActive{..} cid = E.exists . E.from $ \(tutor `E.InnerJ
E.&&. tutorial E.^. TutorialCourse E.==. cid E.&&. tutorial E.^. TutorialCourse E.==. cid
E.&&. E.val (authTagIsActive AuthTutor) E.&&. E.val (authTagIsActive AuthTutor)
isCourseCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) isCourseSheetCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
isCourseCorrector muid AuthTagActive{..} cid = E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do isCourseSheetCorrector muid AuthTagActive{..} cid = E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.where_ $ E.just (sheetCorrector E.^. SheetCorrectorUser) E.==. E.val muid E.where_ $ E.just (sheetCorrector E.^. SheetCorrectorUser) E.==. E.val muid
E.&&. sheet E.^. SheetCourse E.==. cid E.&&. sheet E.^. SheetCourse E.==. cid
E.&&. E.val (authTagIsActive AuthCorrector) E.&&. E.val (authTagIsActive AuthCorrector)
isCourseExamCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
isCourseExamCorrector muid AuthTagActive{..} cid = E.exists . E.from $ \(examCorrector `E.InnerJoin` exam) -> do
E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
E.where_ $ E.just (examCorrector E.^. ExamCorrectorUser) E.==. E.val muid
E.&&. exam E.^. ExamCourse E.==. cid
E.&&. E.val (authTagIsActive AuthExamCorrector)
isCourseParticipant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) isCourseParticipant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
isCourseParticipant muid AuthTagActive{..} cid = E.exists . E.from $ \courseParticipant -> do isCourseParticipant muid AuthTagActive{..} cid = E.exists . E.from $ \courseParticipant -> do
E.where_ $ E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid E.where_ $ E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
@ -105,11 +112,12 @@ isCourseApplicant muid AuthTagActive{..} cid maid = E.exists . E.from $ \courseA
isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool)
isCourseAssociated muid ata cid maid = isCourseAssociated muid ata cid maid =
isCourseLecturer muid ata cid isCourseLecturer muid ata cid
E.||. isCourseTutor muid ata cid E.||. isCourseTutor muid ata cid
E.||. isCourseCorrector muid ata cid E.||. isCourseSheetCorrector muid ata cid
E.||. isCourseParticipant muid ata cid E.||. isCourseExamCorrector muid ata cid
E.||. isCourseApplicant muid ata cid maid E.||. isCourseParticipant muid ata cid
E.||. isCourseApplicant muid ata cid maid
courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool) courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> Maybe (E.SqlExpr (E.Value AllocationId)) -> E.SqlExpr (E.Value Bool)