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

fix(course-visibility): check for mayEdit on course list

Browse Source
This commit is contained in:
Sarah Vaupel 2020-07-29 13:55:54 +02:00
parent 796a8066aa
commit b1d0893993
4 changed files with 104 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
src/Handler/Course/List.hs
View File

@ -10,6 +10,7 @@ import Import
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Utils.Course
import Utils.Form import Utils.Form
-- import Utils.DB -- import Utils.DB
import Handler.Utils hiding (colSchoolShort) 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) type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int) course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
course2Participants (course `E.InnerJoin` _school) = E.subSelectCount . E.from $ \courseParticipant -> course2Participants (course `E.InnerJoin` _school) = numCourseParticipants course
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 :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> course2Registered muid (course `E.InnerJoin` _school) = isCourseParticipant muid course
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)
-- ))
--)
makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) ) makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
=> _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB 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 E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
let participants = course2Participants qin let participants = course2Participants qin
let registered = course2Registered muid qin let registered = course2Registered muid qin
let affiliated = course2Affiliated muid qin let mayView = mayViewCourse muid now course
E.where_ $ whereClause (course, participants, registered, affiliated) E.where_ $ whereClause (course, participants, registered, mayView)
return (course, participants, registered, school) return (course, participants, registered, school)
lecturerQuery cid (user `E.InnerJoin` lecturer) = do lecturerQuery cid (user `E.InnerJoin` lecturer) = do
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
return user return user
isLecturerQuery cid (user `E.InnerJoin` lecturer) = do isEditorQuery course user = E.where_ $ mayEditCourse' muid course
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.&&. E.just (user E.^. UserId) E.==. E.val muid
E.where_ $ cid E.==. lecturer E.^. LecturerCourse
E.&&. E.just (user E.^. UserId) E.==. E.val muid
return user
dbtProj :: DBRow _ -> DB CourseTableData dbtProj :: DBRow _ -> DB CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course) courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course)
>>= traverse (getJustEntity . allocationCourseAllocation . entityVal) >>= traverse (getJustEntity . allocationCourseAllocation . entityVal)
isLecturerList <- E.select $ E.from $ isLecturerQuery $ E.val $ entityKey course isEditorList <- E.select $ E.from $ isEditorQuery course
return (course, participants, registered, school, lecturerList, courseAlloc, not $ null isLecturerList) return (course, participants, registered, school, lecturerList, courseAlloc, not $ null isEditorList)
snd <$> dbTable psValidator DBTable snd <$> dbTable psValidator DBTable
{ dbtSQLQuery { dbtSQLQuery
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
@ -221,7 +185,7 @@ makeCourseTable whereClause colChoices psValidator = do
(_dbrOutput . _3) -- isRegistered (_dbrOutput . _3) -- isRegistered
(_dbrOutput . _4) -- school (_dbrOutput . _4) -- school
(_dbrOutput . _6 . _Just) -- allocation (_dbrOutput . _6 . _Just) -- allocation
(_dbrOutput . _7) -- isLecturer (_dbrOutput . _7) -- mayEditCourse
} }
, dbtParams = def , dbtParams = def
, dbtIdent = "courses" :: Text , dbtIdent = "courses" :: Text
@ -232,7 +196,6 @@ makeCourseTable whereClause colChoices psValidator = do
getCourseListR :: Handler Html getCourseListR :: Handler Html
getCourseListR = do getCourseListR = do
muid <- maybeAuthId muid <- maybeAuthId
now <- liftIO getCurrentTime
let colonnade = widgetColonnade $ mconcat let colonnade = widgetColonnade $ mconcat
[ colCourse -- colCourseDescr [ colCourse -- colCourseDescr
, colDescription , colDescription
@ -241,13 +204,7 @@ getCourseListR = do
, colCShort , colCShort
, maybe mempty (const colRegistered) muid , maybe mempty (const colRegistered) muid
] ]
mnow = E.val $ Just now whereClause (_, _, _, mayView) = mayView
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)
)
validator = def validator = def
& defaultSorting [SortDescBy "term",SortAscBy "course"] & defaultSorting [SortDescBy "term",SortAscBy "course"]
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator coursesTable <- runDB $ makeCourseTable whereClause colonnade validator

4
src/Handler/Utils/Table/Pagination.hs
View File

@ -1325,13 +1325,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders (dbtColonnade ^. _Cornice)) pSortable wHeaders <- maybe (return Nothing) (fmap Just . genHeaders (dbtColonnade ^. _Cornice)) pSortable
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
case dbsTemplate of case dbsTemplate of
DBSTCourse c l r s a l' -> do DBSTCourse c l r s a e -> do
wRows <- forM rows $ \row' -> let wRows <- forM rows $ \row' -> let
Course{..} = row' ^. c . _entityVal Course{..} = row' ^. c . _entityVal
lecturerUsers = row' ^. l lecturerUsers = row' ^. l
courseLecturers = userSurname . entityVal <$> lecturerUsers courseLecturers = userSurname . entityVal <$> lecturerUsers
isRegistered = row' ^. r isRegistered = row' ^. r
isLecturer = row' ^. l' mayEdit = row' ^. e
nmnow = NTop $ Just now nmnow = NTop $ Just now
courseIsVisible = NTop courseVisibleFrom <= nmnow && nmnow <= NTop courseVisibleTo courseIsVisible = NTop courseVisibleFrom <= nmnow && nmnow <= NTop courseVisibleTo
courseSchoolName = schoolName $ row' ^. s . _entityVal courseSchoolName = schoolName $ row' ^. s . _entityVal

90
src/Utils/Course.hs Normal file
View File

@ -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

2
templates/table/course/course-teaser.hamlet
View File

@ -9,7 +9,7 @@
<div .course-teaser__title> <div .course-teaser__title>
<a href=@{CourseR courseTerm courseSchool courseShorthand CShowR}> <a href=@{CourseR courseTerm courseSchool courseShorthand CShowR}>
_{courseName} _{courseName}
$if not courseIsVisible && isLecturer $if not courseIsVisible && mayEdit
\ #{iconInvisible} \ #{iconInvisible}
$if isRegistered $if isRegistered
<div .course-teaser__registration> <div .course-teaser__registration>