fix(course-visibility): check for mayEdit on course list
This commit is contained in:
Sarah Vaupel
parent
796a8066aa
commit
b1d0893993
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
90
src/Utils/Course.hs
Normal file
90
src/Utils/Course.hs
Normal 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
|
||||
@ -9,7 +9,7 @@
|
||||
<div .course-teaser__title>
|
||||
<a href=@{CourseR courseTerm courseSchool courseShorthand CShowR}>
|
||||
_{courseName}
|
||||
$if not courseIsVisible && isLecturer
|
||||
$if not courseIsVisible && mayEdit
|
||||
\ #{iconInvisible}
|
||||
$if isRegistered
|
||||
<div .course-teaser__registration>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user