From dfa70ee7fea2020065699e2d4f0608195a1a0228 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Sat, 8 Aug 2020 12:54:37 +0200 Subject: [PATCH] feat(course-visibility): allow access for exam correctors --- routes | 6 +++--- src/Foundation.hs | 21 ++++++++++++++++----- src/Handler/Course/Register.hs | 3 ++- src/Utils/Course.hs | 24 ++++++++++++++++-------- 4 files changed, 37 insertions(+), 17 deletions(-) diff --git a/routes b/routes index f0d62e665..0d2d28970 100644 --- a/routes +++ b/routes @@ -124,7 +124,7 @@ /course/ CourseListR GET !free !/course/new CourseNewR GET POST !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 /register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬course-registeredANDcourse-time !timeANDallocation-timeAND¬exam-resultANDcourse-registered !lecturerANDallocation-time /register-template CRegisterTemplateR GET !course-time @@ -184,10 +184,10 @@ /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered /communication TCommR GET POST !tutor /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/#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 /corrector-invite ECInviteR GET POST /users EUsersR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index 8f72a6291..52b729b3c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -674,12 +674,23 @@ tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of authId <- maybeExceptT AuthenticationRequired $ return mAuthId isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do 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.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn + 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 + 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 return Authorized r -> $unsupportedAuthPredicate AuthExamCorrector r diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 55ee4d152..e180b0243 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -154,7 +154,8 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do E.||. courseIsVisible now course Nothing E.||. isCourseLecturer 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) $ diff --git a/src/Utils/Course.hs b/src/Utils/Course.hs index 316a10006..fe2d40aff 100644 --- a/src/Utils/Course.hs +++ b/src/Utils/Course.hs @@ -1,7 +1,7 @@ module Utils.Course ( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse' , isSchoolAdmin, isSchoolAdminLike - , isCourseLecturer, isCourseTutor, isCourseCorrector + , isCourseLecturer, isCourseTutor, isCourseSheetCorrector, isCourseExamCorrector , isCourseParticipant, isCourseApplicant , isCourseAssociated , courseIsVisible, courseIsVisible' @@ -80,13 +80,20 @@ isCourseTutor muid AuthTagActive{..} cid = E.exists . E.from $ \(tutor `E.InnerJ E.&&. tutorial E.^. TutorialCourse E.==. cid E.&&. E.val (authTagIsActive AuthTutor) -isCourseCorrector :: 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 :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) +isCourseSheetCorrector muid AuthTagActive{..} cid = E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.where_ $ E.just (sheetCorrector E.^. SheetCorrectorUser) E.==. E.val muid E.&&. sheet E.^. SheetCourse E.==. cid 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 muid AuthTagActive{..} cid = E.exists . E.from $ \courseParticipant -> do 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 muid ata cid maid = - isCourseLecturer muid ata cid - E.||. isCourseTutor muid ata cid - E.||. isCourseCorrector muid ata cid - E.||. isCourseParticipant muid ata cid - E.||. isCourseApplicant muid ata cid maid + isCourseLecturer muid ata cid + E.||. isCourseTutor muid ata cid + E.||. isCourseSheetCorrector muid ata cid + E.||. isCourseExamCorrector muid ata cid + 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)