149 lines
7.0 KiB
Haskell
149 lines
7.0 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Utils.Course
|
|
( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse'
|
|
, isSchoolAdmin, isSchoolAdminLike
|
|
, isCourseLecturer, isCourseTutor, isCourseSheetCorrector, isCourseExamCorrector
|
|
, isCourseParticipant
|
|
, isCourseAssociated
|
|
, courseIsVisible, courseIsVisible'
|
|
, 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 Bool)
|
|
mayViewCourse muid ata now course =
|
|
isSchoolAdminLike muid ata (course E.^. CourseSchool)
|
|
E.||. mayEditCourse muid ata course
|
|
E.||. isCourseAssociated muid ata (course E.^. CourseId)
|
|
E.||. courseIsVisible now course
|
|
|
|
mayViewCourse' :: Maybe UserId
|
|
-> AuthTagActive
|
|
-> UTCTime
|
|
-> Entity Course
|
|
-> E.SqlExpr (E.Value Bool)
|
|
mayViewCourse' muid ata now c@(Entity cid Course{courseSchool}) =
|
|
isSchoolAdminLike muid ata (E.val courseSchool)
|
|
E.||. mayEditCourse' muid ata c
|
|
E.||. isCourseAssociated muid ata (E.val cid)
|
|
E.||. courseIsVisible' now c
|
|
|
|
|
|
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))
|
|
)
|
|
)
|
|
| 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
|
|
|
|
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.||. isCourseSheetCorrector muid ata cid
|
|
E.||. isCourseExamCorrector muid ata cid
|
|
E.||. isCourseParticipant muid ata cid
|
|
|
|
|
|
courseIsVisible :: UTCTime
|
|
-> E.SqlExpr (Entity Course)
|
|
-> E.SqlExpr (E.Value Bool)
|
|
courseIsVisible now course =
|
|
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)
|
|
|
|
courseIsVisible' :: UTCTime
|
|
-> Entity Course
|
|
-> E.SqlExpr (E.Value Bool)
|
|
courseIsVisible' now (Entity _cid Course{..}) = E.val (NTop courseVisibleFrom <= now' && now' <= NTop courseVisibleTo)
|
|
where now' = NTop $ Just now
|
|
|
|
|
|
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
|