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

perf: reduce db-conn-load of tokens

Browse Source
This commit is contained in:
Gregor Kleen 2021-03-24 17:35:40 +01:00
parent fc35c6ac07
commit 2f85cea1de
3 changed files with 90 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

129
src/Foundation/Authorization.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableInstances, InstanceSigs #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints -fprof-auto #-}
module Foundation.Authorization
@ -102,7 +102,9 @@ data AccessPredicate
| APBindDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) (Either AccessPredicate AuthResult))
class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where
evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessPred :: AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
apRunDB :: forall a. ReaderT SqlReadBackend (HandlerFor UniWorX) a -> m a
type family DisabledMonadAPInstance t err :: Constraint where
DisabledMonadAPInstance t err
@ -114,20 +116,28 @@ type family DisabledMonadAPInstance t err :: Constraint where
instance ( BearerAuthSite UniWorX
-- , DisabledMonadAPInstance (HandlerFor UniWorX) ('TypeError.Text "It causes too many database connections")
) => MonadAP (HandlerFor UniWorX) where
evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult
evalAccessPred aPred contCtx cont aid r w = case aPred of
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> p aid r w
(APDB p) -> runDBRead' callStack $ p contCtx cont 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' -> runDBRead' callStack $ p aid' r' w') contCtx cont aid r w
(APBindDB p) -> evalAccessPred (APBind $ \aid' r' w' -> apRunDB $ p aid' r' w') contCtx cont aid r w
apRunDB :: forall a. HasCallStack => ReaderT SqlReadBackend (HandlerFor UniWorX) a -> HandlerFor UniWorX a
apRunDB = runDBRead' callStack
instance BearerAuthSite UniWorX => MonadAP (WidgetFor UniWorX) where
evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WidgetFor UniWorX AuthResult
evalAccessPred aPred contCtx cont aid r w = liftHandler $ evalAccessPred aPred contCtx cont aid r w
apRunDB :: forall a. HasCallStack => ReaderT SqlReadBackend (HandlerFor UniWorX) a -> WidgetFor UniWorX a
apRunDB = liftHandler . apRunDB
instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP (ReaderT backend m) where
evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
(APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
@ -140,6 +150,8 @@ instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBack
Right res' -> return res'
Left p' -> evalAccessPred p' contCtx cont aid r w
apRunDB = hoist liftHandler . withReaderT projectBackend
cacheAP :: ( Binary k
, Typeable v, Binary v
)
@ -262,10 +274,12 @@ isDryRun :: ( HasCallStack
=> HandlerFor UniWorX Bool
isDryRun = fmap unIsDryRun . cached . fmap MkIsDryRun $ runDBRead isDryRunDB
isDryRunDB :: forall m.
isDryRunDB :: forall m backend.
( HasCallStack
, MonadAP m, MonadCatch m
, BearerAuthSite UniWorX
, WithRunDB backend (HandlerFor UniWorX) m
, BackendCompatible SqlReadBackend backend
)
=> m Bool
isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM
@ -313,15 +327,20 @@ askBearerUnsafe = ExceptT . $cachedHere . liftHandler . runExceptT $ do
$logWarnS "AuthToken" $ tshow other
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
validateBearer :: BearerAuthSite UniWorX
validateBearer :: forall m.
( HasCallStack
, MonadHandler m, HandlerSite m ~ UniWorX
, MonadCatch m, MonadAP m
, BearerAuthSite UniWorX
)
=> Maybe (AuthId UniWorX)
-> Route UniWorX
-> Bool -- ^ @isWrite@
-> BearerToken UniWorX
-> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult
-> m AuthResult
validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token'
where
validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) AuthResult
validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult m AuthResult
validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
iforM_ bearerRoutes $ \case
BearerTokenRouteEval -> \routes -> guardMExceptT (HashSet.member route routes) $ unauthorizedI MsgUnauthorizedTokenInvalidRoute
@ -329,27 +348,6 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
cRoute <- MaybeT getCurrentRoute
guard $ HashSet.member cRoute routes
bearerAuthority' <- flip foldMapM bearerAuthority $ \case
Left tVal
| JSON.Success groupName <- JSON.fromJSON tVal -> do
Entity _ primary <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . getBy $ UniquePrimaryUserGroupMember groupName Active
case bearerImpersonate of
Nothing -> return . Set.singleton $ userGroupMemberUser primary
Just iuid | iuid == userGroupMemberUser primary -> return . Set.singleton $ userGroupMemberUser primary
| otherwise -> do
unlessM (lift $ exists [UserGroupMemberUser ==. iuid, UserGroupMemberGroup ==. groupName]) $
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
return $ Set.singleton iuid
| otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
Right uid -> case bearerImpersonate of
Just iuid | uid == iuid -> return $ Set.singleton uid
| otherwise -> do
cID <- encrypt iuid
unlessM (lift $ is _Authorized <$> evalAccessWithFor [(AuthToken, False)] (Just uid) (AdminHijackUserR cID) True) $
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
return $ Set.singleton iuid
Nothing -> return $ Set.singleton uid
let
-- Prevent infinite loops
noTokenAuth :: AuthDNF -> AuthDNF
@ -357,12 +355,38 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
eval :: forall m'. MonadAP m' => AuthTagsEval m'
eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite''
guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority
bearerAuthority' <- hoist apRunDB $ do
bearerAuthority' <- flip foldMapM bearerAuthority $ \case
Left tVal
| JSON.Success groupName <- JSON.fromJSON tVal -> do
Entity _ primary <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . getBy $ UniquePrimaryUserGroupMember groupName Active
case bearerImpersonate of
Nothing -> return . Set.singleton $ userGroupMemberUser primary
Just iuid | iuid == userGroupMemberUser primary -> return . Set.singleton $ userGroupMemberUser primary
| otherwise -> do
unlessM (lift $ exists [UserGroupMemberUser ==. iuid, UserGroupMemberGroup ==. groupName]) $
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
return $ Set.singleton iuid
| otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
Right uid -> case bearerImpersonate of
Just iuid | uid == iuid -> return $ Set.singleton uid
| otherwise -> do
cID <- encrypt iuid
unlessM (lift $ is _Authorized <$> evalAccessWithFor [(AuthToken, False)] (Just uid) (AdminHijackUserR cID) True) $
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
return $ Set.singleton iuid
Nothing -> return $ Set.singleton uid
guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority
forM_ bearerAuthority' $ \uid -> do
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid
guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
return bearerAuthority'
forM_ bearerAuthority' $ \uid -> do
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid
guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
authorityVal <- do
dnf <- throwLeft $ routeAuthTags route
lift . evalWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite
@ -375,46 +399,59 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
return Authorized
maybeBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX
maybeBearerToken :: ( HasCallStack
, MonadHandler m, HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX
, MonadAP m
, MonadCatch m
) => m (Maybe (BearerToken UniWorX))
maybeBearerToken = liftHandler . runMaybeT $ catchIfMaybeT cPred requireBearerToken
maybeBearerToken = $cachedHere . runMaybeT $ catchIfMaybeT cPred requireBearerToken
where
cPred err = any ($ err)
[ is $ _HCError . _PermissionDenied
, is $ _HCError . _NotAuthenticated
]
requireBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX
requireBearerToken :: forall m.
( HasCallStack
, MonadHandler m, HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX
, MonadAP m
, MonadCatch m
)
=> m (BearerToken UniWorX)
requireBearerToken = liftHandler $ do
requireBearerToken = do
bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe
mAuthId <- defaultMaybeAuthId -- `maybeAuthId` would be an infinite loop; this is equivalent to `maybeAuthId` but ignoring `bearerImpersonate` from any valid token
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- isWriteRequest currentRoute
guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer
isWrite <- liftHandler $ isWriteRequest currentRoute
guardAuthResult =<< validateBearer mAuthId currentRoute isWrite bearer
return bearer
requireCurrentBearerRestrictions :: forall a m.
( MonadHandler m, HandlerSite m ~ UniWorX
( HasCallStack
, MonadHandler m, HandlerSite m ~ UniWorX
, FromJSON a, ToJSON a
, BearerAuthSite UniWorX
, MonadAP m
, MonadCatch m
)
=> m (Maybe a)
requireCurrentBearerRestrictions = liftHandler . runMaybeT $ do
bearer <- requireBearerToken
requireCurrentBearerRestrictions = runMaybeT $ do
bearer <- lift requireBearerToken
route <- MaybeT getCurrentRoute
hoistMaybe $ bearer ^? _bearerRestrictionIx route
maybeCurrentBearerRestrictions :: forall a m.
( MonadHandler m, HandlerSite m ~ UniWorX
( HasCallStack
, MonadHandler m, HandlerSite m ~ UniWorX
, FromJSON a, ToJSON a
, BearerAuthSite UniWorX
, MonadAP m
, MonadCatch m
)
=> m (Maybe a)
maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
maybeCurrentBearerRestrictions = runMaybeT $ do
bearer <- MaybeT maybeBearerToken
route <- MaybeT getCurrentRoute
hoistMaybe $ bearer ^? _bearerRestrictionIx route
@ -453,7 +490,9 @@ cacheAPSystemFunction f mExp = cacheAP mExp (AuthCacheSystemFunctionList f) mkFu
E.&&. E.not_ (userSystemFunction E.^. UserSystemFunctionIsOptOut)
return $ userSystemFunction E.^. UserSystemFunctionUser
tagAccessPredicate :: BearerAuthSite UniWorX
tagAccessPredicate :: ( HasCallStack
, BearerAuthSite UniWorX
)
=> AuthTag -> AccessPredicate
tagAccessPredicate AuthFree = trueAP
tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right diffHour) $ \mAuthId' route' _ adminList -> if

8
src/Foundation/Instances.hs
View File

@ -107,6 +107,7 @@ instance Yesod UniWorX where
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
isAuthorized :: HasCallStack => Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult
isAuthorized r w = runDBRead $ evalAccess r w
addStaticContent = UniWorX.addStaticContent
@ -184,14 +185,15 @@ instance YesodAuth UniWorX where
_other -> Auth.germanMessage
where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls
maybeAuthId = runMaybeT $ authIdFromBearer <|> MaybeT defaultMaybeAuthId
maybeAuthId :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => m (Maybe (AuthId UniWorX))
maybeAuthId = $cachedHere . runMaybeT $ authIdFromBearer <|> MaybeT defaultMaybeAuthId
where authIdFromBearer = do
BearerToken{..} <- MaybeT maybeBearerToken
BearerToken{..} <- MaybeT . liftHandler $ runDBRead maybeBearerToken
hoistMaybe bearerImpersonate
instance YesodAuthPersist UniWorX where
getAuthEntity :: (HasCallStack, MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (Maybe User)
getAuthEntity = liftHandler . runDBRead' callStack . get
getAuthEntity = liftHandler . runDBRead . get
instance YesodMail UniWorX where

2
src/Handler/Submission/Helper.hs
View File

@ -120,7 +120,7 @@ makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUs
miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag)
submittorsForm' = maybeT submittorsForm $ do
restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array)
restr <- MaybeT (liftHandler $ maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array)
let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x
submittors <- fmap (pure @FormResult @[Either UserEmail CryptoUUIDUser]) . forM (toList restr) $ hoistMaybe . preview _Submittor
fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt