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

refactor(course-visibility): make course utils require less

Browse Source
This commit is contained in:
Sarah Vaupel 2020-07-30 11:52:28 +02:00
parent 1b86d61998
commit 0c3f2011dd
4 changed files with 52 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Handler/Allocation/Show.hs
View File

@ -43,7 +43,7 @@ getAShowR tid ssh ash = do
E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId)
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
E.&&. mayViewCourse muid ata now course E.&&. mayViewCourse' muid ata now course
E.orderBy [E.asc $ course E.^. CourseName] E.orderBy [E.asc $ course E.^. CourseName]
let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> let hasTemplate = E.exists . E.from $ \courseAppInstructionFile ->
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId

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

@ -60,10 +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) = numCourseParticipants course course2Participants (course `E.InnerJoin` _school) = numCourseParticipants $ course E.^. CourseId
course2Registered :: Maybe UserId -> AuthTagActive -> CourseTableExpr -> E.SqlExpr (E.Value Bool) course2Registered :: Maybe UserId -> AuthTagActive -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid ata (course `E.InnerJoin` _school) = isCourseParticipant muid ata course course2Registered muid ata (course `E.InnerJoin` _school) = isCourseParticipant muid ata $ 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
@ -76,14 +76,14 @@ 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 ata qin let registered = course2Registered muid ata qin
let mayView = mayViewCourse muid ata now course let mayView = mayViewCourse' muid ata now course
E.where_ $ whereClause (course, participants, registered, mayView) 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
isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course isEditorQuery course user = E.where_ $ mayEditCourse muid ata course
E.&&. E.just (user E.^. UserId) E.==. E.val muid E.&&. E.just (user E.^. UserId) E.==. E.val muid
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

4
src/Handler/Term.hs
View File

@ -6,7 +6,7 @@ module Handler.Term
import Import import Import
import Utils.Course (mayViewCourse) import Utils.Course (mayViewCourse')
import Handler.Utils import Handler.Utils
@ -74,7 +74,7 @@ getTermShowR = do
where dbtSQLQuery term = return (term, courseCount) where dbtSQLQuery term = return (term, courseCount)
where courseCount = E.subSelectCount . E.from $ \course -> where courseCount = E.subSelectCount . E.from $ \course ->
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
E.&&. mayViewCourse muid ata now course E.&&. mayViewCourse' muid ata now course
dbtRowKey = (E.^. TermId) dbtRowKey = (E.^. TermId)
dbtProj = return . dbrOutput dbtProj = return . dbrOutput
dbtColonnade = widgetColonnade $ mconcat dbtColonnade = widgetColonnade $ mconcat

97
src/Utils/Course.hs
View File

@ -1,10 +1,7 @@
module Utils.Course module Utils.Course
( mayViewCourse, mayEditCourse ( mayViewCourse, mayViewCourse', mayEditCourse, mayEditCourse'
, mayEditCourse'
, isCourseLecturer, isCourseTutor, isCourseCorrector, isCourseParticipant, isCourseAssociated , isCourseLecturer, isCourseTutor, isCourseCorrector, isCourseParticipant, isCourseAssociated
, isCourseLecturer' , courseIsVisible, courseIsVisible'
, courseIsVisible
, courseIsVisible'
, numCourseParticipants , numCourseParticipants
) where ) where
@ -14,74 +11,70 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
-- TODO switch from E.SqlExpr (Entity Course) to CourseId wherever possible mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> Entity Course -> E.SqlExpr (E.Value Bool)
mayViewCourse muid ata now c@(Entity cid course) =
mayEditCourse muid ata c
E.||. isCourseAssociated muid ata (E.val cid)
E.||. E.val (courseIsVisible' now course)
mayViewCourse' :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
mayViewCourse' muid ata now course =
mayEditCourse' muid ata course
E.||. isCourseAssociated muid ata (course E.^. CourseId)
E.||. courseIsVisible now course
mayViewCourse :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) mayEditCourse :: Maybe UserId -> AuthTagActive -> Entity Course -> E.SqlExpr (E.Value Bool)
mayViewCourse muid ata now course = mayEditCourse muid ata@AuthTagActive{..} (Entity cid Course{..}) = (E.exists . E.from $ \(user `E.InnerJoin` userFunction) -> do
mayEditCourse muid ata course
E.||. isCourseAssociated muid ata course
E.||. courseIsVisible now course
mayEditCourse :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
mayEditCourse muid ata@AuthTagActive{..} 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.&&. E.val (authTagIsActive AuthAdmin)
) E.||. isCourseLecturer muid ata course
mayEditCourse' :: Maybe UserId -> AuthTagActive -> Entity Course -> E.SqlExpr (E.Value Bool)
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 (authTagIsActive AuthAdmin) E.&&. E.val (authTagIsActive AuthAdmin)
) E.||. isCourseLecturer' muid ata cid ) E.||. isCourseLecturer muid ata (E.val cid)
isCourseLecturer :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) mayEditCourse' :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
isCourseLecturer muid AuthTagActive{..} course = E.exists . E.from $ \(user `E.InnerJoin` lecturer) -> 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.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.&&. E.val (authTagIsActive AuthAdmin)
) E.||. isCourseLecturer muid ata (course E.^. CourseId)
isCourseLecturer :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
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.==. course E.^. CourseId E.&&. lecturer E.^. LecturerCourse E.==. cid
E.&&. E.val (authTagIsActive AuthLecturer) E.&&. E.val (authTagIsActive AuthLecturer)
isCourseLecturer' :: Maybe UserId -> AuthTagActive -> CourseId -> E.SqlExpr (E.Value Bool) isCourseTutor :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
isCourseLecturer' muid AuthTagActive{..} cid = E.exists . E.from $ \(user `E.InnerJoin` lecturer) -> do isCourseTutor muid AuthTagActive{..} cid = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> 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
E.&&. E.val (authTagIsActive AuthLecturer)
isCourseTutor :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool)
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.==. cid
E.&&. E.val (authTagIsActive AuthTutor) E.&&. E.val (authTagIsActive AuthTutor)
isCourseCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) isCourseCorrector :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
isCourseCorrector muid AuthTagActive{..} course = E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do isCourseCorrector muid AuthTagActive{..} cid = 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.==. cid
E.&&. E.val (authTagIsActive AuthCorrector) E.&&. E.val (authTagIsActive AuthCorrector)
isCourseParticipant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) isCourseParticipant :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
isCourseParticipant muid AuthTagActive{..} course = E.exists . E.from $ \courseParticipant -> do isCourseParticipant muid AuthTagActive{..} cid = 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.==. cid
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.&&. E.val (authTagIsActive AuthCourseRegistered) -- TODO is this the auth tag I want here? E.&&. E.val (authTagIsActive AuthCourseRegistered) -- TODO is this the auth tag I want here?
isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Bool) isCourseAssociated :: Maybe UserId -> AuthTagActive -> E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Bool)
isCourseAssociated muid ata course = isCourseAssociated muid ata cid =
isCourseLecturer muid ata course isCourseLecturer muid ata cid
E.||. isCourseTutor muid ata course E.||. isCourseTutor muid ata cid
E.||. isCourseCorrector muid ata course E.||. isCourseCorrector muid ata cid
E.||. isCourseParticipant muid ata course E.||. isCourseParticipant muid ata cid
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 =
@ -96,7 +89,7 @@ courseIsVisible' :: UTCTime -> Course -> Bool
courseIsVisible' now Course{..} = NTop courseVisibleFrom <= now' && now' <= NTop courseVisibleTo courseIsVisible' now Course{..} = NTop courseVisibleFrom <= now' && now' <= NTop courseVisibleTo
where now' = NTop $ Just now where now' = NTop $ Just now
numCourseParticipants :: E.SqlExpr (Entity Course) -> E.SqlExpr (E.Value Int) numCourseParticipants :: E.SqlExpr (E.Value CourseId) -> E.SqlExpr (E.Value Int)
numCourseParticipants course = E.subSelectCount . E.from $ \courseParticipant -> numCourseParticipants cid = E.subSelectCount . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. cid
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive