perf: try to reduce db-conn-load of cached auth
This commit is contained in:
Gregor Kleen
parent
b2815141dd
commit
0e50e6ebce
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user