From b1d08939930c56fdc0efaf0e133a5feffa1cee64 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Wed, 29 Jul 2020 13:55:54 +0200 Subject: [PATCH] fix(course-visibility): check for mayEdit on course list --- src/Handler/Course/List.hs | 65 +++------------ src/Handler/Utils/Table/Pagination.hs | 4 +- src/Utils/Course.hs | 90 +++++++++++++++++++++ templates/table/course/course-teaser.hamlet | 2 +- 4 files changed, 104 insertions(+), 57 deletions(-) create mode 100644 src/Utils/Course.hs diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 7b065505b..628ad7358 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -10,6 +10,7 @@ import Import import Data.Maybe (fromJust) +import Utils.Course import Utils.Form -- import Utils.DB import Handler.Utils hiding (colSchoolShort) @@ -59,44 +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) = E.subSelectCount . E.from $ \courseParticipant -> - E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId - E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive +course2Participants (course `E.InnerJoin` _school) = numCourseParticipants course 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 - --- Is this user affiliated with the course in any way (except for being registered)? -course2Affiliated :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) -course2Affiliated muid (course `E.InnerJoin` _school) = (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.||. (E.exists (E.from (\(user `E.InnerJoin` (tutor `E.InnerJoin` tutorial)) -> do - E.on (user E.^. UserId E.==. tutor E.^. TutorUser) - E.on (tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId) - E.where_ (E.just (user E.^. UserId) E.==. E.val muid - E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId) - )) - ) E.||. (E.exists (E.from (\(user `E.InnerJoin` (sheetCorrector `E.InnerJoin` sheet)) -> do - E.on (user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser) - E.on (sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId) - E.where_ (E.just (user E.^. UserId) E.==. E.val muid - E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId) - )) - ) - --) E.||. (E.exists (E.from (\(user `E.InnerJoin` (submissionUser `E.InnerJoin` (submission `E.InnerJoin` sheet))) -> do - -- E.on (user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser) - -- E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId) - -- E.on (submission E.^. SubmissionSheet E.==. sheet E.^. SheetId) - -- E.where_ (E.just (user E.^. UserId) E.==. E.val muid - -- E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId) - -- )) - --) +course2Registered muid (course `E.InnerJoin` _school) = isCourseParticipant muid course makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) ) => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget @@ -108,25 +75,22 @@ makeCourseTable whereClause colChoices psValidator = do E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId let participants = course2Participants qin let registered = course2Registered muid qin - let affiliated = course2Affiliated muid qin - E.where_ $ whereClause (course, participants, registered, affiliated) + let mayView = mayViewCourse muid 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 - isLecturerQuery cid (user `E.InnerJoin` lecturer) = do - E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser - E.where_ $ cid E.==. lecturer E.^. LecturerCourse - E.&&. E.just (user E.^. UserId) E.==. E.val muid - return user + isEditorQuery course user = E.where_ $ mayEditCourse' muid 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 lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course) >>= traverse (getJustEntity . allocationCourseAllocation . entityVal) - isLecturerList <- E.select $ E.from $ isLecturerQuery $ E.val $ entityKey course - return (course, participants, registered, school, lecturerList, courseAlloc, not $ null isLecturerList) + isEditorList <- E.select $ E.from $ isEditorQuery course + return (course, participants, registered, school, lecturerList, courseAlloc, not $ null isEditorList) snd <$> dbTable psValidator DBTable { dbtSQLQuery , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId @@ -221,7 +185,7 @@ makeCourseTable whereClause colChoices psValidator = do (_dbrOutput . _3) -- isRegistered (_dbrOutput . _4) -- school (_dbrOutput . _6 . _Just) -- allocation - (_dbrOutput . _7) -- isLecturer + (_dbrOutput . _7) -- mayEditCourse } , dbtParams = def , dbtIdent = "courses" :: Text @@ -232,7 +196,6 @@ makeCourseTable whereClause colChoices psValidator = do getCourseListR :: Handler Html getCourseListR = do muid <- maybeAuthId - now <- liftIO getCurrentTime let colonnade = widgetColonnade $ mconcat [ colCourse -- colCourseDescr , colDescription @@ -241,13 +204,7 @@ getCourseListR = do , colCShort , maybe mempty (const colRegistered) muid ] - mnow = E.val $ Just now - whereClause (course, _, registered, affiliated) = registered E.||. affiliated - E.||. (E.isJust (course E.^. CourseVisibleFrom) - E.&&. course E.^. CourseVisibleFrom E.<=. mnow - E.&&. (E.isNothing (course E.^. CourseVisibleTo) - E.||. mnow E.<=. course E.^. CourseVisibleTo) - ) + whereClause (_, _, _, mayView) = mayView validator = def & defaultSorting [SortDescBy "term",SortAscBy "course"] coursesTable <- runDB $ makeCourseTable whereClause colonnade validator diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index e9ca08981..9c0441ca4 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1325,13 +1325,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db wHeaders <- maybe (return Nothing) (fmap Just . genHeaders (dbtColonnade ^. _Cornice)) pSortable now <- liftIO getCurrentTime case dbsTemplate of - DBSTCourse c l r s a l' -> do + DBSTCourse c l r s a e -> do wRows <- forM rows $ \row' -> let Course{..} = row' ^. c . _entityVal lecturerUsers = row' ^. l courseLecturers = userSurname . entityVal <$> lecturerUsers isRegistered = row' ^. r - isLecturer = row' ^. l' + mayEdit = row' ^. e nmnow = NTop $ Just now courseIsVisible = NTop courseVisibleFrom <= nmnow && nmnow <= NTop courseVisibleTo courseSchoolName = schoolName $ row' ^. s . _entityVal diff --git a/src/Utils/Course.hs b/src/Utils/Course.hs new file mode 100644 index 000000000..950fa0d79 --- /dev/null +++ b/src/Utils/Course.hs @@ -0,0 +1,90 @@ +module Utils.Course + ( mayViewCourse, mayEditCourse + , mayEditCourse' + , isCourseLecturer, isCourseTutor, isCourseCorrector, isCourseParticipant, isCourseAssociated + , isCourseLecturer' + , courseIsVisible + , numCourseParticipants + ) where + +import Import.NoFoundation + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + + +-- TODO switch from E.SqlExpr (Entity Course) to CourseId + + +mayViewCourse :: Maybe UserId -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +mayViewCourse muid now course = + mayEditCourse muid course + E.||. isCourseAssociated muid course + E.||. courseIsVisible now course + +mayEditCourse :: Maybe UserId -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +mayEditCourse muid 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.||. isCourseLecturer muid course + +mayEditCourse' :: Maybe UserId -> Entity Course -> E.SqlExpr (E.Value Bool) +mayEditCourse' muid (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.||. isCourseLecturer' muid cid + +isCourseLecturer :: Maybe UserId -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +isCourseLecturer muid course = 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 + +isCourseLecturer' :: Maybe UserId -> CourseId -> E.SqlExpr (E.Value Bool) +isCourseLecturer' muid 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 + +isCourseTutor :: Maybe UserId -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +isCourseTutor muid course = 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 + +isCourseCorrector :: Maybe UserId -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +isCourseCorrector muid course = 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 + +isCourseParticipant :: Maybe UserId -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +isCourseParticipant muid course = 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.^. CourseParticipantState E.==. E.val CourseParticipantActive + +isCourseAssociated :: Maybe UserId -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +isCourseAssociated muid course = + isCourseLecturer muid course + E.||. isCourseTutor muid course + E.||. isCourseCorrector muid course + E.||. isCourseParticipant muid course + +courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) +courseIsVisible now course = + E.isJust (course E.^. CourseVisibleFrom) + E.&&. course E.^. CourseVisibleFrom E.<=. E.val (Just now) + E.&&. ( + E.isNothing (course E.^. CourseVisibleTo) + E.||. E.val (Just now) E.<=. course E.^. CourseVisibleTo + ) + +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 + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive diff --git a/templates/table/course/course-teaser.hamlet b/templates/table/course/course-teaser.hamlet index 5db2cf4b0..c8e6b8ea2 100644 --- a/templates/table/course/course-teaser.hamlet +++ b/templates/table/course/course-teaser.hamlet @@ -9,7 +9,7 @@
_{courseName} - $if not courseIsVisible && isLecturer + $if not courseIsVisible && mayEdit \ #{iconInvisible} $if isRegistered