diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index b0ec6ab67..1dca93457 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -43,7 +43,7 @@ getAShowR tid ssh ash = do E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId - E.&&. mayViewCourse muid ata now course + E.&&. mayViewCourse' muid ata now course E.orderBy [E.asc $ course E.^. CourseName] let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 10cf8c8a0..c7a1bf551 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -60,10 +60,10 @@ colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School) course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int) -course2Participants (course `E.InnerJoin` _school) = numCourseParticipants course +course2Participants (course `E.InnerJoin` _school) = numCourseParticipants $ course E.^. CourseId course2Registered :: Maybe UserId -> AuthTagActive -> CourseTableExpr -> E.SqlExpr (E.Value Bool) -course2Registered muid ata (course `E.InnerJoin` _school) = isCourseParticipant muid ata course +course2Registered muid ata (course `E.InnerJoin` _school) = isCourseParticipant muid ata $ course E.^. CourseId makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) ) => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget @@ -76,14 +76,14 @@ makeCourseTable whereClause colChoices psValidator = do E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId let participants = course2Participants qin let registered = course2Registered muid ata qin - let mayView = mayViewCourse muid ata now course + let mayView = mayViewCourse' muid ata now course E.where_ $ whereClause (course, participants, registered, mayView) return (course, participants, registered, school) lecturerQuery cid (user `E.InnerJoin` lecturer) = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer return user - isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course + isEditorQuery course user = E.where_ $ mayEditCourse muid ata course E.&&. E.just (user E.^. UserId) E.==. E.val muid dbtProj :: DBRow _ -> DB CourseTableData dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index ed50bdc30..e8843d17a 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -6,7 +6,7 @@ module Handler.Term import Import -import Utils.Course (mayViewCourse) +import Utils.Course (mayViewCourse') import Handler.Utils @@ -74,7 +74,7 @@ getTermShowR = do where dbtSQLQuery term = return (term, courseCount) where courseCount = E.subSelectCount . E.from $ \course -> E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm - E.&&. mayViewCourse muid ata now course + E.&&. mayViewCourse' muid ata now course dbtRowKey = (E.^. TermId) dbtProj = return . dbrOutput dbtColonnade = widgetColonnade $ mconcat diff --git a/src/Utils/Course.hs b/src/Utils/Course.hs index c699e95e8..f5ee489b3 100644 --- a/src/Utils/Course.hs +++ b/src/Utils/Course.hs @@ -1,10 +1,7 @@ module Utils.Course - ( mayViewCourse, mayEditCourse - , mayEditCourse' + ( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse' , isCourseLecturer, isCourseTutor, isCourseCorrector, isCourseParticipant, isCourseAssociated - , isCourseLecturer' - , courseIsVisible - , courseIsVisible' + , courseIsVisible, courseIsVisible' , numCourseParticipants ) where @@ -14,74 +11,70 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E --- TODO switch from E.SqlExpr (Entity Course) to CourseId wherever possible +mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> Entity Course -> E.SqlExpr (E.Value Bool) +mayViewCourse muid ata now c@(Entity cid course) = + mayEditCourse muid ata c + E.||. isCourseAssociated muid ata (E.val cid) + E.||. E.val (courseIsVisible' now course) +mayViewCourse' :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +mayViewCourse' muid ata now course = + mayEditCourse' muid ata course + E.||. isCourseAssociated muid ata (course E.^. CourseId) + E.||. courseIsVisible now course -mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) -mayViewCourse muid ata now course = - mayEditCourse muid ata course - E.||. isCourseAssociated muid ata course - E.||. courseIsVisible now course - -mayEditCourse :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) -mayEditCourse muid ata@AuthTagActive{..} course = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do - E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser - E.where_ $ E.just (user E.^. UserId) E.==. E.val muid - E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin - E.&&. userFunction E.^. UserFunctionSchool E.==. course E.^. CourseSchool - E.&&. E.val (authTagIsActive AuthAdmin) - ) E.||. isCourseLecturer muid ata course - -mayEditCourse' :: Maybe UserId -> AuthTagActive -> Entity Course -> E.SqlExpr (E.Value Bool) -mayEditCourse' muid ata@AuthTagActive{..} (Entity cid Course{..}) = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do +mayEditCourse :: Maybe UserId -> AuthTagActive -> Entity Course -> E.SqlExpr (E.Value Bool) +mayEditCourse muid ata@AuthTagActive{..} (Entity cid Course{..}) = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser E.where_ $ E.just (user E.^. UserId) E.==. E.val muid E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin E.&&. userFunction E.^. UserFunctionSchool E.==. E.val courseSchool E.&&. E.val (authTagIsActive AuthAdmin) - ) E.||. isCourseLecturer' muid ata cid + ) E.||. isCourseLecturer muid ata (E.val cid) -isCourseLecturer :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) -isCourseLecturer muid AuthTagActive{..} course = E.exists . E.from $ \(user `E.InnerJoin` lecturer) -> do +mayEditCourse' :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +mayEditCourse' muid ata@AuthTagActive{..} course = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do + E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser + E.where_ $ E.just (user E.^. UserId) E.==. E.val muid + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin + E.&&. userFunction E.^. UserFunctionSchool E.==. course E.^. CourseSchool + E.&&. E.val (authTagIsActive AuthAdmin) + ) E.||. isCourseLecturer muid ata (course E.^. CourseId) + +isCourseLecturer :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) +isCourseLecturer muid AuthTagActive{..} cid = E.exists . E.from $ \(user `E.InnerJoin` lecturer) -> do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ E.just (user E.^. UserId) E.==. E.val muid - E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. lecturer E.^. LecturerCourse E.==. cid E.&&. E.val (authTagIsActive AuthLecturer) -isCourseLecturer' :: Maybe UserId -> AuthTagActive -> CourseId -> E.SqlExpr (E.Value Bool) -isCourseLecturer' muid AuthTagActive{..} cid = E.exists . E.from $ \(user `E.InnerJoin` lecturer) -> do - E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser - E.where_ $ E.just (user E.^. UserId) E.==. E.val muid - E.&&. lecturer E.^. LecturerCourse E.==. E.val cid - E.&&. E.val (authTagIsActive AuthLecturer) - -isCourseTutor :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) -isCourseTutor muid AuthTagActive{..} course = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do +isCourseTutor :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) +isCourseTutor muid AuthTagActive{..} cid = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val muid - E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.&&. tutorial E.^. TutorialCourse E.==. cid E.&&. E.val (authTagIsActive AuthTutor) -isCourseCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) -isCourseCorrector muid AuthTagActive{..} course = E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do +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 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.==. course E.^. CourseId + E.&&. sheet E.^. SheetCourse E.==. cid E.&&. E.val (authTagIsActive AuthCorrector) -isCourseParticipant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) -isCourseParticipant muid AuthTagActive{..} course = E.exists . E.from $ \courseParticipant -> do +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 - E.&&. courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. courseParticipant E.^. CourseParticipantCourse E.==. cid E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.&&. E.val (authTagIsActive AuthCourseRegistered) -- TODO is this the auth tag I want here? -isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) -isCourseAssociated muid ata course = - isCourseLecturer muid ata course - E.||. isCourseTutor muid ata course - E.||. isCourseCorrector muid ata course - E.||. isCourseParticipant muid ata course +isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool) +isCourseAssociated muid ata cid = + isCourseLecturer muid ata cid + E.||. isCourseTutor muid ata cid + E.||. isCourseCorrector muid ata cid + E.||. isCourseParticipant muid ata cid courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) courseIsVisible now course = @@ -96,7 +89,7 @@ courseIsVisible' :: UTCTime -> Course -> Bool courseIsVisible' now Course{..} = NTop courseVisibleFrom <= now' && now' <= NTop courseVisibleTo where now' = NTop $ Just now -numCourseParticipants :: E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Int) -numCourseParticipants course = E.subSelectCount . E.from $ \courseParticipant -> - E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId +numCourseParticipants :: E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Int) +numCourseParticipants cid = E.subSelectCount . E.from $ \courseParticipant -> + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. cid E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive