From 5cfe4e049f9f776243591d58294897ed541103f3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 May 2019 22:08:06 +0200 Subject: [PATCH] Even more caching --- src/Foundation.hs | 58 +++++++++++++++++++++++------------------------ 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 58c077a60..6b5c9f508 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -612,7 +612,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret return Authorized tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId E.where_ $ tutor E.^. TutorUser E.==. E.val authId @@ -622,12 +622,12 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ] case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity tutid _ <- MaybeT . lift . getBy $ UniqueTutorial cid tutn + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid) return Authorized CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh guard $ cid `Set.member` Map.keysSet resMap return Authorized _ -> do @@ -719,7 +719,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do + [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid @@ -732,7 +732,7 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of CTutorialR tid ssh csh tutn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId @@ -745,7 +745,7 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout return Authorized CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId @@ -763,14 +763,14 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of whenExceptT ok Authorized participant <- decrypt cID -- participant is currently registered - authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant has at least one submission - authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -779,7 +779,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is member of a submissionGroup - authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant @@ -787,7 +787,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a sheet corrector - authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant @@ -795,7 +795,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a tutorial user - authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant @@ -803,7 +803,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is tutor for this course - authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutor E.^. TutorUser E.==. E.val participant @@ -811,7 +811,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is lecturer for this course - authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant E.&&. course E.^. CourseTerm E.==. E.val tid @@ -821,26 +821,26 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of r -> $unsupportedAuthPredicate AuthParticipant r tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn - registered <- lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ] + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn + registered <- $cachedHereBinary tutId . lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ] guard $ NTop tutorialCapacity > NTop (Just registered) return Authorized CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do - Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] + Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + registered <- $cachedHereBinary cid . lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate AuthCapacity r tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn case (tutorialRegGroup, mAuthId) of (Nothing, _) -> return Authorized (_, Nothing) -> return AuthenticationRequired (Just rGroup, Just uid) -> do - [E.Value hasOther] <- lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do + [E.Value hasOther] <- $cachedHereBinary (uid, rGroup) . lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial E.where_ $ participant E.^. TutorialParticipantUser E.==. E.val uid E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) @@ -850,9 +850,9 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - assertM_ (<= 0) . lift $ count [ CourseParticipantCourse ==. cid ] - assertM_ ((<= 0) :: Int -> Bool) . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] + assertM_ ((<= 0) :: Int -> Bool) . $cachedHereBinary cid . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return E.countRows @@ -860,7 +860,7 @@ tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of r -> $unsupportedAuthPredicate AuthEmpty r tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do - Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized r -> $unsupportedAuthPredicate AuthMaterials r @@ -887,8 +887,8 @@ tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of r -> $unsupportedAuthPredicate AuthUserSubmissions r tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do - Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn guard submissionModeCorrector return Authorized r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r @@ -909,7 +909,7 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- decrypt cID - SystemMessage{..} <- MaybeT $ get smId + SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId let isAuthenticated = isJust mAuthId guard $ not systemMessageAuthenticatedOnly || isAuthenticated return Authorized