From 0e50e6ebce9c9cbc2b15ac77f61d24906166c5db Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Mar 2021 21:43:24 +0100 Subject: [PATCH] perf: try to reduce db-conn-load of cached auth --- src/Foundation/Authorization.hs | 140 +++++++++++++++++--------------- 1 file changed, 74 insertions(+), 66 deletions(-) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 0b618f1f4..cd5f4be14 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -99,7 +99,7 @@ data AccessPredicate | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult) | APDB (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult) | APBind (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either AccessPredicate AuthResult)) - | APBindDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) (Either AccessPredicate AuthResult)) + | APBindDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either (ReaderT SqlReadBackend (HandlerFor UniWorX) (Either AccessPredicate AuthResult)) (Either AccessPredicate AuthResult))) class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where evalAccessPred :: AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult @@ -121,12 +121,9 @@ instance ( BearerAuthSite UniWorX (APPure p) -> runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> p aid r w (APDB p) -> apRunDB $ p contCtx cont aid r w - (APBind p) -> do - res <- p aid r w - case res of - Right res' -> return res' - Left p' -> evalAccessPred p' contCtx cont aid r w - (APBindDB p) -> evalAccessPred (APBind $ \aid' r' w' -> apRunDB $ p aid' r' w') contCtx cont aid r w + (APBind p) -> evalAccessPred (APBindDB $ \aid' r' w' -> Right <$> p aid' r' w') contCtx cont aid r w + (APBindDB p) -> let contAP p' = evalAccessPred p' contCtx cont aid r w + in p aid r w >>= either apRunDB return >>= either contAP return apRunDB :: forall a. HasCallStack => ReaderT SqlReadBackend (HandlerFor UniWorX) a -> HandlerFor UniWorX a apRunDB = runDBRead' callStack @@ -143,56 +140,67 @@ instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBack (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> lift $ p aid r w (APDB p) -> p contCtx cont aid r w - (APBind p) -> evalAccessPred (APBindDB $ \aid' r' w' -> lift $ p aid' r' w') contCtx cont aid r w - (APBindDB p) -> do - res <- p aid r w - case res of - Right res' -> return res' - Left p' -> evalAccessPred p' contCtx cont aid r w + (APBind p) -> evalAccessPred (APBindDB $ \aid' r' w' -> Right <$> p aid' r' w') contCtx cont aid r w + (APBindDB p) -> let contAP p' = evalAccessPred p' contCtx cont aid r w + in lift (p aid r w) >>= either id return >>= either contAP return apRunDB = hoist liftHandler . withReaderT projectBackend -cacheAP :: ( Binary k - , Typeable v, Binary v - ) - => Maybe Expiry - -> k - -> HandlerFor UniWorX v - -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) - -> AccessPredicate -cacheAP mExp k mkV cont = APBind $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV +-- cacheAP :: ( Binary k +-- , Typeable v, Binary v +-- ) +-- => Maybe Expiry +-- -> k +-- -> HandlerFor UniWorX v +-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) +-- -> AccessPredicate +-- cacheAP mExp k mkV cont = APBind $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV --- cacheAPDB :: ( Binary k --- , Typeable v, Binary v --- ) --- => Maybe Expiry --- -> k --- -> ReaderT SqlReadBackend (HandlerFor UniWorX) v --- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)) --- -> AccessPredicate --- cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV +cacheAPDB :: ( Binary k + , Typeable v, Binary v + ) + => Maybe Expiry + -> k + -> ReaderT SqlReadBackend (HandlerFor UniWorX) v + -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) + -> AccessPredicate +cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do + cachedV <- memcachedByGet k + case cachedV of + Just v -> fmap Right . either (return . Left) (fmap Right) $ cont mAuthId route isWrite v + Nothing -> return . Left $ do + v <- mkV + memcachedBySet mExp k v + either (return . Left) (fmap Right . lift) $ cont mAuthId route isWrite v -cacheAP' :: ( Binary k - , Typeable v, Binary v - ) - => Maybe Expiry - -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, HandlerFor UniWorX v)) - -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) - -> AccessPredicate -cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of - Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV - Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing - --- cacheAPDB' :: ( Binary k --- , Typeable v, Binary v --- ) --- => Maybe Expiry --- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, ReaderT SqlReadBackend (HandlerFor UniWorX) v)) --- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)) --- -> AccessPredicate --- cacheAPDB' mExp mkKV cont = APBindDB $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of +-- cacheAP' :: ( Binary k +-- , Typeable v, Binary v +-- ) +-- => Maybe Expiry +-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, HandlerFor UniWorX v)) +-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) +-- -> AccessPredicate +-- cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of -- Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV -- Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing + +cacheAPDB' :: ( Binary k + , Typeable v, Binary v + ) + => Maybe Expiry + -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, ReaderT SqlReadBackend (HandlerFor UniWorX) v)) + -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) + -> AccessPredicate +cacheAPDB' mExp mkKV cont = APBindDB $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of + Just (k, mkV) -> do + cachedV <- memcachedByGet k + case cachedV of + Just v -> fmap Right . either (return . Left) (fmap Right) . cont mAuthId route isWrite $ Just v + Nothing -> return . Left $ do + v <- mkV + memcachedBySet mExp k v + either (return . Left) (fmap Right . lift) . cont mAuthId route isWrite $ Just v + Nothing -> fmap Right . either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult @@ -472,9 +480,9 @@ cacheAPSchoolFunction :: BearerAuthSite UniWorX -> Maybe Expiry -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Set (AuthId UniWorX) -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) -> AccessPredicate -cacheAPSchoolFunction f mExp = cacheAP mExp (AuthCacheSchoolFunctionList f) mkFunctionList +cacheAPSchoolFunction f mExp = cacheAPDB mExp (AuthCacheSchoolFunctionList f) mkFunctionList where - mkFunctionList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do + mkFunctionList = fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val f return $ userFunction E.^. UserFunctionUser @@ -483,9 +491,9 @@ cacheAPSystemFunction :: BearerAuthSite UniWorX -> Maybe Expiry -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Set (AuthId UniWorX) -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) -> AccessPredicate -cacheAPSystemFunction f mExp = cacheAP mExp (AuthCacheSystemFunctionList f) mkFunctionList +cacheAPSystemFunction f mExp = cacheAPDB mExp (AuthCacheSystemFunctionList f) mkFunctionList where - mkFunctionList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ \userSystemFunction -> do + mkFunctionList = fmap (setOf $ folded . _Value) . E.select . E.from $ \userSystemFunction -> do E.where_ $ userSystemFunction E.^. UserSystemFunctionFunction E.==. E.val f E.&&. E.not_ (userSystemFunction E.^. UserSystemFunctionIsOptOut) return $ userSystemFunction E.^. UserSystemFunctionUser @@ -672,7 +680,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do return $ Unauthorized "Route under development" #endif -tagAccessPredicate AuthLecturer = cacheAP' (Just $ Right diffMinute) mkLecturerList $ \mAuthId' route' _ mLecturerList -> if +tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecturerList $ \mAuthId' route' _ mLecturerList -> if | Just lecturerList <- mLecturerList , maybe True (`Set.notMember` lecturerList) mAuthId' -> Right $ case route' of _ | is _Nothing mAuthId' -> return AuthenticationRequired @@ -725,20 +733,20 @@ tagAccessPredicate AuthLecturer = cacheAP' (Just $ Right diffMinute) mkLecturerL AllocationR{} -> cacheLecturerList EExamR{} -> Just ( AuthCacheExternalExamStaffList - , runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser) + , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser) ) _other -> Just ( AuthCacheSchoolFunctionList SchoolLecturer - , runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do + , fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolLecturer return $ userFunction E.^. UserFunctionUser ) where cacheLecturerList = Just ( AuthCacheLecturerList - , runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser) + , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser) ) -tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCorrectorList mkCorrectorList $ \mAuthId' route' _ correctorList -> if +tagAccessPredicate AuthCorrector = cacheAPDB (Just $ Right diffMinute) AuthCacheCorrectorList mkCorrectorList $ \mAuthId' route' _ correctorList -> if | maybe True (`Set.notMember` correctorList) mAuthId' -> Right $ case route' of _ | is _Nothing mAuthId' -> return AuthenticationRequired CSubmissionR{} -> unauthorizedI MsgUnauthorizedSubmissionCorrector @@ -778,12 +786,12 @@ tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCo E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId return Authorized where - mkCorrectorList = runDBRead . execWriterT $ do + mkCorrectorList = execWriterT $ do tellM . fmap (setOf $ folded . _Value . _Just) . E.select . E.from $ \submission -> do E.where_ . E.isJust $ submission E.^. SubmissionRatingBy return $ submission E.^. SubmissionRatingBy tellM . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. SheetCorrectorUser) -tagAccessPredicate AuthExamCorrector = cacheAP (Just $ Right diffMinute) AuthCacheExamCorrectorList mkExamCorrectorList $ \mAuthId' route' _ examCorrectorList -> if +tagAccessPredicate AuthExamCorrector = cacheAPDB (Just $ Right diffMinute) AuthCacheExamCorrectorList mkExamCorrectorList $ \mAuthId' route' _ examCorrectorList -> if | maybe True (`Set.notMember` examCorrectorList) mAuthId' -> Right $ case route' of _ | is _Nothing mAuthId' -> return AuthenticationRequired CExamR{} -> unauthorizedI MsgUnauthorizedExamCorrector @@ -815,8 +823,8 @@ tagAccessPredicate AuthExamCorrector = cacheAP (Just $ Right diffMinute) AuthCac return Authorized r -> $unsupportedAuthPredicate AuthExamCorrector r where - mkExamCorrectorList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser) -tagAccessPredicate AuthTutor = cacheAP (Just $ Right diffMinute) AuthCacheTutorList mkTutorList $ \mAuthId' route' _ tutorList -> if + mkExamCorrectorList = fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser) +tagAccessPredicate AuthTutor = cacheAPDB (Just $ Right diffMinute) AuthCacheTutorList mkTutorList $ \mAuthId' route' _ tutorList -> if | maybe True (`Set.notMember` tutorList) mAuthId' -> Right $ case route' of _ | is _Nothing mAuthId' -> return AuthenticationRequired CTutorialR{} -> unauthorizedI MsgUnauthorizedTutorialTutor @@ -846,7 +854,7 @@ tagAccessPredicate AuthTutor = cacheAP (Just $ Right diffMinute) AuthCacheTutorL guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) return Authorized where - mkTutorList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. TutorUser) + mkTutorList = fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. TutorUser) tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh @@ -1151,7 +1159,7 @@ tagAccessPredicate AuthExamTime = APDB $ \_ _ _ route _ -> case route of guard $ NTop (Just now) >= NTop examFinished return Authorized r -> $unsupportedAuthPredicate AuthExamTime r -tagAccessPredicate AuthCourseRegistered = cacheAP' (Just $ Right diffMinute) mkAuthCacheCourseRegisteredList $ \mAuthId' route' _ mCourseRegisteredList -> if +tagAccessPredicate AuthCourseRegistered = cacheAPDB' (Just $ Right diffMinute) mkAuthCacheCourseRegisteredList $ \mAuthId' route' _ mCourseRegisteredList -> if | Just courseRegisteredList <- mCourseRegisteredList , maybe True (`Set.notMember` courseRegisteredList) mAuthId' -> Right $ case route' of _ | is _Nothing mAuthId' -> return AuthenticationRequired @@ -1174,7 +1182,7 @@ tagAccessPredicate AuthCourseRegistered = cacheAP' (Just $ Right diffMinute) mkA mkAuthCacheCourseRegisteredList _ route _ = case route of CourseR tid ssh csh _ -> Just ( AuthCacheCourseRegisteredList tid ssh csh - , runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do + , fmap (setOf $ folded . _Value) . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.&&. course E.^. CourseTerm E.==. E.val tid