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

perf(authorization): generalize routes before pred exec for caching

Browse Source
This commit is contained in:
Gregor Kleen 2021-08-02 11:25:26 +02:00
parent 97e37eb716
commit a17d2dc779
1 changed files with 24 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/Foundation/Authorization.hs
View File

@ -1863,6 +1863,28 @@ routeAuthTags = fmap predDNFEntail . ofoldM parse defaultAuthDNF . routeAttrs
Just t' -> Right . predDNFOr prev . PredDNF $ Set.singleton t' Just t' -> Right . predDNFOr prev . PredDNF $ Set.singleton t'
Nothing -> Left $ InvalidAuthTag t Nothing -> Left $ InvalidAuthTag t
broadenRoute :: AuthTag -> Route UniWorX -> Route UniWorX
broadenRoute aTag route = case (aTag, route) of
(AuthAdmin, CourseR tid ssh csh _) -> CourseR tid ssh csh CShowR
(AuthAdmin, AllocationR tid ssh ash _) -> AllocationR tid ssh ash AShowR
(AuthAdmin, SchoolR ssh _) -> SchoolR ssh SchoolEditR
(AuthAdmin, _) -> NewsR
(AuthStudent, _) -> NewsR
(AuthExamOffice, CExamR tid ssh csh examn _) -> CExamR tid ssh csh examn EShowR
(AuthExamOffice, EExamR tid ssh coursen examn _) -> EExamR tid ssh coursen examn EEShowR
(AuthExamOffice, CourseR _ ssh _ _) -> SchoolR ssh SchoolEditR
(AuthExamOffice, SchoolR ssh _) -> SchoolR ssh SchoolEditR
(AuthExamOffice, _) -> NewsR
(AuthLecturer, CourseR tid ssh csh _) -> CourseR tid ssh csh CShowR
(AuthLecturer, AllocationR tid ssh ash _) -> AllocationR tid ssh ash AShowR
(AuthLecturer, EExamR tid ssh coursen examn _) -> EExamR tid ssh coursen examn EEShowR
(AuthLecturer, _) -> NewsR
_other -> route
evalAuthTags :: forall ctx m. (HasCallStack, Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m evalAuthTags :: forall ctx m. (HasCallStack, Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m
-- ^ `tell`s disabled predicates, identified as pivots -- ^ `tell`s disabled predicates, identified as pivots
evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
@ -1876,8 +1898,9 @@ evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable
authTagIsInactive = not . authTagIsActive authTagIsInactive = not . authTagIsActive
evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (ctx, AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for5 memo (const evalAccessPred') ctx authTag mAuthId route isWrite evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (ctx, AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for5 memo (const evalAccessPred') ctx authTag mAuthId route'' isWrite
where where
route'' = broadenRoute authTag route
evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
observeAuthTagEvaluation authTag' (classifyHandler route') $ do observeAuthTagEvaluation authTag' (classifyHandler route') $ do