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

refactor(course-utils): better auth tag checks in course utils

Browse Source
This commit is contained in:
Sarah Vaupel 2020-07-29 16:16:11 +02:00
parent 7d3c5b11a5
commit 9473d657a6
1 changed files with 33 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
src/Utils/Course.hs
View File

@ -6,7 +6,6 @@ module Utils.Course
, courseIsVisible , courseIsVisible
, courseIsVisible' , courseIsVisible'
, numCourseParticipants , numCourseParticipants
, ActiveAuthTags(..)
) where ) where
import Import.NoFoundation import Import.NoFoundation
@ -15,80 +14,74 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
-- this is only a subset of auth tags (includes only the ones needed here)
data ActiveAuthTags = ActiveAuthTags
{ aatAdmin, aatLecturer, aatTutor, aatCorrector, aatParticipant :: Bool
}
-- TODO switch from E.SqlExpr (Entity Course) to CourseId wherever possible -- TODO switch from E.SqlExpr (Entity Course) to CourseId wherever possible
-- TODO also check auth predicates everywhere
mayViewCourse :: Maybe UserId -> ActiveAuthTags -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
mayViewCourse muid aats now course = mayViewCourse muid ata now course =
mayEditCourse muid aats course mayEditCourse muid ata course
E.||. isCourseAssociated muid aats course E.||. isCourseAssociated muid ata course
E.||. courseIsVisible now course E.||. courseIsVisible now course
mayEditCourse :: Maybe UserId -> ActiveAuthTags -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) mayEditCourse :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
mayEditCourse muid aats@ActiveAuthTags{..} course = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do mayEditCourse muid ata@AuthTagActive{..} course = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do
E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
E.where_ $ E.just (user E.^. UserId) E.==. E.val muid E.where_ $ E.just (user E.^. UserId) E.==. E.val muid
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
E.&&. userFunction E.^. UserFunctionSchool E.==. course E.^. CourseSchool E.&&. userFunction E.^. UserFunctionSchool E.==. course E.^. CourseSchool
E.&&. E.val aatAdmin E.&&. E.val (authTagIsActive AuthAdmin)
) E.||. isCourseLecturer muid aats course ) E.||. isCourseLecturer muid ata course
mayEditCourse' :: Maybe UserId -> ActiveAuthTags -> Entity Course -> E.SqlExpr (E.Value Bool) mayEditCourse' :: Maybe UserId -> AuthTagActive -> Entity Course -> E.SqlExpr (E.Value Bool)
mayEditCourse' muid aats@ActiveAuthTags{..} (Entity cid Course{..}) = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do mayEditCourse' muid ata@AuthTagActive{..} (Entity cid Course{..}) = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do
E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
E.where_ $ E.just (user E.^. UserId) E.==. E.val muid E.where_ $ E.just (user E.^. UserId) E.==. E.val muid
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
E.&&. userFunction E.^. UserFunctionSchool E.==. E.val courseSchool E.&&. userFunction E.^. UserFunctionSchool E.==. E.val courseSchool
E.&&. E.val aatAdmin E.&&. E.val (authTagIsActive AuthAdmin)
) E.||. isCourseLecturer' muid aats cid ) E.||. isCourseLecturer' muid ata cid
isCourseLecturer :: Maybe UserId -> ActiveAuthTags -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) isCourseLecturer :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
isCourseLecturer muid ActiveAuthTags{..} course = E.exists . E.from $ \(user `E.InnerJoin` lecturer) -> do isCourseLecturer muid AuthTagActive{..} course = E.exists . E.from $ \(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_ $ E.just (user E.^. UserId) E.==. E.val muid E.where_ $ E.just (user E.^. UserId) E.==. E.val muid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.&&. E.val aatLecturer E.&&. E.val (authTagIsActive AuthLecturer)
isCourseLecturer' :: Maybe UserId -> ActiveAuthTags -> CourseId -> E.SqlExpr (E.Value Bool) isCourseLecturer' :: Maybe UserId -> AuthTagActive -> CourseId -> E.SqlExpr (E.Value Bool)
isCourseLecturer' muid ActiveAuthTags{..} cid = E.exists . E.from $ \(user `E.InnerJoin` lecturer) -> do isCourseLecturer' muid AuthTagActive{..} cid = E.exists . E.from $ \(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_ $ E.just (user E.^. UserId) E.==. E.val muid E.where_ $ E.just (user E.^. UserId) E.==. E.val muid
E.&&. lecturer E.^. LecturerCourse E.==. E.val cid E.&&. lecturer E.^. LecturerCourse E.==. E.val cid
E.&&. E.val aatLecturer E.&&. E.val (authTagIsActive AuthLecturer)
isCourseTutor :: Maybe UserId -> ActiveAuthTags -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) isCourseTutor :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
isCourseTutor muid ActiveAuthTags{..} course = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do isCourseTutor muid AuthTagActive{..} course = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val muid E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val muid
E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
E.&&. E.val aatTutor E.&&. E.val (authTagIsActive AuthTutor)
isCourseCorrector :: Maybe UserId -> ActiveAuthTags -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) isCourseCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
isCourseCorrector muid ActiveAuthTags{..} course = E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do isCourseCorrector muid AuthTagActive{..} course = E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.where_ $ E.just (sheetCorrector E.^. SheetCorrectorUser) E.==. E.val muid E.where_ $ E.just (sheetCorrector E.^. SheetCorrectorUser) E.==. E.val muid
E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId
E.&&. E.val aatCorrector E.&&. E.val (authTagIsActive AuthCorrector)
isCourseParticipant :: Maybe UserId -> ActiveAuthTags -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) isCourseParticipant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
isCourseParticipant muid ActiveAuthTags{..} course = E.exists . E.from $ \courseParticipant -> do isCourseParticipant muid AuthTagActive{..} course = E.exists . E.from $ \courseParticipant -> do
E.where_ $ E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid E.where_ $ E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.&&. E.val aatParticipant E.&&. E.val (authTagIsActive AuthCourseRegistered) -- TODO is this the auth tag I want here?
isCourseAssociated :: Maybe UserId -> ActiveAuthTags -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
isCourseAssociated muid aats course = isCourseAssociated muid ata course =
isCourseLecturer muid aats course isCourseLecturer muid ata course
E.||. isCourseTutor muid aats course E.||. isCourseTutor muid ata course
E.||. isCourseCorrector muid aats course E.||. isCourseCorrector muid ata course
E.||. isCourseParticipant muid aats course E.||. isCourseParticipant muid ata course
courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) courseIsVisible :: UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
courseIsVisible now course = courseIsVisible now course =