162 lines
8.7 KiB
Haskell
162 lines
8.7 KiB
Haskell
module Utils.Course
|
|
( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse'
|
|
, isSchoolAdmin, isSchoolAdminLike
|
|
, isCourseLecturer, isCourseTutor, isCourseSheetCorrector, isCourseExamCorrector
|
|
, isCourseParticipant, isCourseApplicant
|
|
, isCourseAssociated
|
|
, courseIsVisible, courseIsVisible'
|
|
, courseAllocationRegistrationOpen
|
|
, numCourseParticipants
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value (Maybe AllocationId)) -> E.SqlExpr (E.Value Bool)
|
|
mayViewCourse muid ata now course maid =
|
|
isSchoolAdminLike muid ata (course E.^. CourseSchool)
|
|
E.||. mayEditCourse muid ata course
|
|
E.||. isCourseAssociated muid ata (course E.^. CourseId) maid
|
|
E.||. courseIsVisible now course maid
|
|
|
|
mayViewCourse' :: Maybe UserId -> AuthTagActive -> UTCTime -> Entity Course -> Maybe AllocationId -> E.SqlExpr (E.Value Bool)
|
|
mayViewCourse' muid ata now c@(Entity cid Course{courseSchool}) maid =
|
|
isSchoolAdminLike muid ata (E.val courseSchool)
|
|
E.||. mayEditCourse' muid ata c
|
|
E.||. isCourseAssociated muid ata (E.val cid) (E.val maid)
|
|
E.||. courseIsVisible' now c maid
|
|
|
|
|
|
mayEditCourse :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
|
|
mayEditCourse muid ata course =
|
|
isSchoolAdmin muid ata (course E.^. CourseSchool)
|
|
E.||. isCourseLecturer muid ata (course E.^. CourseId)
|
|
|
|
mayEditCourse' :: Maybe UserId -> AuthTagActive -> Entity Course -> E.SqlExpr (E.Value Bool)
|
|
mayEditCourse' muid ata (Entity cid Course{..}) =
|
|
isSchoolAdmin muid ata (E.val courseSchool)
|
|
E.||. isCourseLecturer muid ata (E.val cid)
|
|
|
|
|
|
isSchoolAdmin :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value SchoolId) -> E.SqlExpr (E.Value Bool)
|
|
isSchoolAdmin muid AuthTagActive{..} ssh
|
|
| Just uid <- muid, authTagIsActive AuthAdmin = E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do
|
|
E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
|
|
E.where_ $ user E.^. UserId E.==. E.val uid
|
|
E.&&. userFunction E.^. UserFunctionSchool E.==. ssh
|
|
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
|
| otherwise = E.false
|
|
|
|
isSchoolAdminLike :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value SchoolId) -> E.SqlExpr (E.Value Bool)
|
|
isSchoolAdminLike muid ata@AuthTagActive{..} ssh
|
|
| Just uid <- muid = isSchoolAdmin muid ata ssh E.||. (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do
|
|
E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
|
|
E.where_ $ user E.^. UserId E.==. E.val uid
|
|
E.&&. userFunction E.^. UserFunctionSchool E.==. ssh
|
|
E.&&. ( (userFunction E.^. UserFunctionFunction E.==. E.val SchoolEvaluation
|
|
E.&&. E.val (authTagIsActive AuthEvaluation))
|
|
E.||. (userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
|
|
E.&&. E.val (authTagIsActive AuthExamOffice))
|
|
E.||. (userFunction E.^. UserFunctionFunction E.==. E.val SchoolAllocation
|
|
E.&&. E.val (authTagIsActive AuthAllocationAdmin))
|
|
)
|
|
)
|
|
| otherwise = E.false
|
|
|
|
isCourseLecturer :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
|
|
isCourseLecturer muid AuthTagActive{..} cid
|
|
| Just uid <- muid, authTagIsActive AuthLecturer = E.exists . E.from $ \(user `E.InnerJoin` lecturer) -> do
|
|
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
|
|
E.where_ $ user E.^. UserId E.==. E.val uid
|
|
E.&&. lecturer E.^. LecturerCourse E.==. cid
|
|
| otherwise = E.false
|
|
|
|
isCourseTutor :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
|
|
isCourseTutor muid AuthTagActive{..} cid
|
|
| Just uid <- muid, authTagIsActive AuthTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
|
|
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
|
E.where_ $ tutor E.^. TutorUser E.==. E.val uid
|
|
E.&&. tutorial E.^. TutorialCourse E.==. cid
|
|
| otherwise = E.false
|
|
|
|
isCourseSheetCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
|
|
isCourseSheetCorrector muid AuthTagActive{..} cid
|
|
| Just uid <- muid, authTagIsActive AuthCorrector = E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do
|
|
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
|
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
|
|
E.&&. sheet E.^. SheetCourse E.==. cid
|
|
| otherwise = E.false
|
|
|
|
isCourseExamCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
|
|
isCourseExamCorrector muid AuthTagActive{..} cid
|
|
| Just uid <- muid, authTagIsActive AuthExamCorrector = E.exists . E.from $ \(examCorrector `E.InnerJoin` exam) -> do
|
|
E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
|
|
E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val uid
|
|
E.&&. exam E.^. ExamCourse E.==. cid
|
|
| otherwise = E.false
|
|
|
|
isCourseParticipant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
|
|
isCourseParticipant muid AuthTagActive{..} cid
|
|
| Just uid <- muid, authTagIsActive AuthCourseRegistered = E.exists . E.from $ \courseParticipant -> E.where_ $
|
|
courseParticipant E.^. CourseParticipantUser E.==. E.val uid
|
|
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. cid
|
|
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.&&. E.val (authTagIsActive AuthCourseRegistered)
|
|
| otherwise = E.false
|
|
|
|
isCourseApplicant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value (Maybe AllocationId)) -> E.SqlExpr (E.Value Bool)
|
|
isCourseApplicant muid AuthTagActive{..} cid maid
|
|
| Just uid <- muid, authTagIsActive AuthApplicant = E.exists . E.from $ \courseApplication -> E.where_ $
|
|
courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
|
E.&&. courseApplication E.^. CourseApplicationCourse E.==. cid
|
|
E.&&. E.maybe E.true
|
|
(\aid -> E.just aid E.==. courseApplication E.^. CourseApplicationAllocation)
|
|
maid
|
|
| otherwise = E.false
|
|
|
|
isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value (Maybe AllocationId)) -> E.SqlExpr (E.Value Bool)
|
|
isCourseAssociated 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) -> E.SqlExpr (E.Value (Maybe AllocationId)) -> E.SqlExpr (E.Value Bool)
|
|
courseIsVisible now course maid =
|
|
(E.maybe E.false (\visibleFrom -> visibleFrom E.<=. E.val now) (course E.^. CourseVisibleFrom)
|
|
E.&&. E.maybe E.true (\visibleTo -> E.val now E.<=. visibleTo) (course E.^. CourseVisibleTo)
|
|
) E.||. courseAllocationRegistrationOpen now (course E.^. CourseId) maid
|
|
|
|
courseIsVisible' :: UTCTime -> Entity Course -> Maybe AllocationId -> E.SqlExpr (E.Value Bool)
|
|
courseIsVisible' now (Entity cid Course{..}) maid =
|
|
E.val (NTop courseVisibleFrom <= now' && now' <= NTop courseVisibleTo)
|
|
E.||. courseAllocationRegistrationOpen now (E.val cid) (E.val maid)
|
|
where now' = NTop $ Just now
|
|
|
|
|
|
courseAllocationRegistrationOpen :: UTCTime -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value (Maybe AllocationId)) -> E.SqlExpr (E.Value Bool)
|
|
courseAllocationRegistrationOpen now cid maid = E.exists . E.from $ \(allocationCourse `E.InnerJoin` allocation) -> do
|
|
E.on $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
|
|
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. cid
|
|
E.&&. E.maybe
|
|
E.true
|
|
(\registerFrom -> registerFrom E.<=. E.val now)
|
|
(allocation E.^. AllocationRegisterFrom)
|
|
E.&&. E.maybe
|
|
E.true
|
|
(\registerTo -> E.val now E.<=. registerTo)
|
|
(allocation E.^. AllocationRegisterTo)
|
|
E.&&. E.maybe E.true (\aid -> aid E.==. allocation E.^. AllocationId) maid
|
|
|
|
|
|
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
|