From 25cf94657067dfc60e9acdb370274873ae0b6a6e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 27 Nov 2019 22:27:59 +0100 Subject: [PATCH] fix: work around regression in esqueleto --- src/Foundation.hs | 43 ++++++++++++++++++++++++++++--------------- 1 file changed, 28 insertions(+), 15 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 483064a9f..65e368fd0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -859,30 +859,43 @@ tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> exceptT return return $ do 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 - 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 + hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . 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.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.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. exam E.^. ExamName E.==. E.val examn - guardMExceptT hasResult (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 `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 + hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . 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_ $ (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.^. CourseSchool E.==. E.val ssh 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 r -> $unsupportedAuthPredicate AuthExamRegistered r tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of