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

fix: work around regression in esqueleto

Browse Source
This commit is contained in:
Gregor Kleen 2019-11-27 22:27:59 +01:00
parent 167d391508
commit 25cf946570
1 changed files with 28 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
src/Foundation.hs
View File

@ -859,30 +859,43 @@ tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of
CExamR tid ssh csh examn _ -> exceptT return return $ do CExamR tid ssh csh examn _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` (examResult `E.FullOuterJoin` (examPartResult `E.InnerJoin` examPart))) -> do hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
E.on $ examPartResult E.?. ExamPartResultExamPart E.==. examPart E.?. ExamPartId E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam
E.on $ examResult E.?. ExamResultExam E.==. examPart E.?. ExamPartExam
E.on $ E.just (exam E.^. ExamId) E.==. examResult E.?. ExamResultExam
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ (examResult E.?. ExamResultUser E.==. E.just (E.val authId) E.||. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val authId)) E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. exam E.^. ExamName E.==. E.val examn E.&&. exam E.^. ExamName E.==. E.val examn
guardMExceptT hasResult (unauthorizedI MsgUnauthorizedExamResult) hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do
return Authorized E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
CourseR tid ssh csh _ -> exceptT return return $ do E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` (examResult `E.FullOuterJoin` (examPartResult `E.InnerJoin` examPart))) -> do
E.on $ examPartResult E.?. ExamPartResultExamPart E.==. examPart E.?. ExamPartId
E.on $ examResult E.?. ExamResultExam E.==. examPart E.?. ExamPartExam
E.on $ E.just (exam E.^. ExamId) E.==. examResult E.?. ExamResultExam
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ (examResult E.?. ExamResultUser E.==. E.just (E.val authId) E.||. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val authId)) E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
guardMExceptT hasResult (unauthorizedI MsgUnauthorizedExamResult) E.&&. exam E.^. ExamName E.==. E.val examn
guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
return Authorized
CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do
E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthExamRegistered r r -> $unsupportedAuthPredicate AuthExamRegistered r
tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of