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

perf: try to reduce db connection load of auth

Browse Source
This commit is contained in:
Gregor Kleen 2021-03-23 11:07:05 +01:00
parent 1036926470
commit da724654ed
12 changed files with 655 additions and 614 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
src/Foundation/Authorization.hs
View File

@ -8,10 +8,10 @@ module Foundation.Authorization
, wouldHaveReadAccessTo, wouldHaveWriteAccessTo
, wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
, AuthContext(..), getAuthContext
, isDryRun
, isDryRun, isDryRunDB
, maybeBearerToken, requireBearerToken
, requireCurrentBearerRestrictions, maybeCurrentBearerRestrictions
, BearerAuthSite
, BearerAuthSite, MonadAP
, routeAuthTags
, orAR, andAR, notAR, trueAR, falseAR
, evalWorkflowRoleFor, evalWorkflowRoleFor'
@ -60,6 +60,9 @@ import qualified Data.Conduit.Combinators as C
import qualified Data.Binary as Binary
import GHC.TypeLits (TypeError)
import qualified GHC.TypeLits as TypeError (ErrorMessage(..))
type BearerAuthSite site
= ( MonadCrypto (HandlerFor site)
@ -101,8 +104,17 @@ data AccessPredicate
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
instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where
evalAccessPred aPred contCtx cont aid r w = liftHandler $ case aPred of
type family DisabledMonadAPInstance t err :: Constraint where
DisabledMonadAPInstance t err
= TypeError ( 'TypeError.Text "Used dangerous MonadAP instance for: " 'TypeError.:<>: 'TypeError.ShowType t
'TypeError.:$$: 'TypeError.Text "This instance is currently disabled via TypeError because: " 'TypeError.:<>: err
'TypeError.:$$: 'TypeError.Text "Please consider removing the usage triggering this error message before re-enabling or removing the instance."
)
instance ( BearerAuthSite UniWorX
-- , DisabledMonadAPInstance (HandlerFor UniWorX) ('TypeError.Text "It causes too many database connections")
) => MonadAP (HandlerFor UniWorX) where
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
@ -113,6 +125,9 @@ instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuth
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
instance BearerAuthSite UniWorX => MonadAP (WidgetFor UniWorX) where
evalAccessPred aPred contCtx cont aid r w = liftHandler $ evalAccessPred aPred contCtx cont aid r w
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
@ -238,23 +253,32 @@ getAuthContext = liftHandler $ do
return authCtx
isDryRun :: forall m.
( HasCallStack
, MonadHandler m, HandlerSite m ~ UniWorX
newtype IsDryRun = MkIsDryRun { unIsDryRun :: Bool }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
isDryRun :: ( HasCallStack
, BearerAuthSite UniWorX
)
=> m Bool
isDryRun = $cachedHere . liftHandler $ orM
=> HandlerFor UniWorX Bool
isDryRun = fmap unIsDryRun . cached . fmap MkIsDryRun $ runDBRead isDryRunDB
isDryRunDB :: forall m.
( HasCallStack
, MonadAP m, MonadCatch m
, BearerAuthSite UniWorX
)
=> m Bool
isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM
[ hasGlobalPostParam PostDryRun
, hasGlobalGetParam GetDryRun
, and2M bearerDryRun bearerRequired
]
where
bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value
bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do
mAuthId <- defaultMaybeAuthId
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- isWriteRequest currentRoute
bearerRequired = maybeT (return True) . catchIfMaybeT cPred $ do
mAuthId <- liftHandler defaultMaybeAuthId
currentRoute <- liftHandler $ maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- liftHandler $ isWriteRequest currentRoute
let noTokenAuth :: AuthDNF -> AuthDNF
noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
@ -1894,7 +1918,7 @@ wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo ro
evalWorkflowRoleFor' :: forall m backend.
( HasCallStack
, MonadAP m
, MonadAP (ReaderT backend m), MonadIO m
, BackendCompatible SqlReadBackend backend
)
=> (forall m'. MonadAP m' => AuthTagsEval m')
@ -1941,7 +1965,7 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do
WorkflowRoleAuthorized{..} -> eval (predDNFEntail $ workflowRoleAuthorized `predDNFOr` defaultAuthDNF) mAuthId route isWrite
evalWorkflowRoleFor :: ( HasCallStack
, MonadAP m
, MonadAP (ReaderT backend m), MonadIO m
, BackendCompatible SqlReadBackend backend
)
=> Maybe UserId
@ -1964,8 +1988,9 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do
return result
hasWorkflowRole :: ( HasCallStack
, MonadAP m
, MonadAP (ReaderT backend m)
, BackendCompatible SqlReadBackend backend
, MonadHandler m, HandlerSite m ~ UniWorX
)
=> Maybe WorkflowWorkflowId
-> WorkflowRole UserId
@ -1978,10 +2003,12 @@ hasWorkflowRole mwwId wRole route isWrite = do
mayViewWorkflowAction' :: forall backend m fileid.
( HasCallStack
, MonadAP m
, MonadAP (ReaderT backend m)
, BackendCompatible SqlReadBackend backend
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
, MonadCatch m
, MonadHandler m, HandlerSite m ~ UniWorX
, MonadUnliftIO m
)
=> (forall m'. MonadAP m' => AuthTagsEval m')
-> Maybe UserId
@ -1991,7 +2018,7 @@ mayViewWorkflowAction' :: forall backend m fileid.
mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do
WorkflowWorkflow{..} <- MaybeT . lift $ get wwId
rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
cID <- hoist lift . catchMaybeT (Proxy @CryptoIDError) . lift $ encrypt wwId
cID <- catchMaybeT (Proxy @CryptoIDError) . lift . lift $ encrypt wwId
WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
evalWorkflowRole'' role = lift $ is _Authorized <$> evalWorkflowRoleFor' eval mAuthId (Just wwId) role canonRoute False
@ -2007,10 +2034,12 @@ mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT
mayViewWorkflowAction :: forall backend m fileid.
( HasCallStack
, MonadAP m
, MonadAP (ReaderT backend m)
, BackendCompatible SqlReadBackend backend
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
, MonadCatch m
, MonadHandler m, HandlerSite m ~ UniWorX
, MonadUnliftIO m
)
=> Maybe UserId
-> WorkflowWorkflowId

2
src/Foundation/Instances.hs
View File

@ -107,7 +107,7 @@ instance Yesod UniWorX where
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
isAuthorized = evalAccess
isAuthorized r w = runDBRead $ evalAccess r w
addStaticContent = UniWorX.addStaticContent

1102
src/Foundation/Navigation.hs
View File

File diff suppressed because it is too large Load Diff

57
src/Foundation/SiteLayout.hs
View File

@ -89,24 +89,6 @@ siteLayout' overrideHeading widget = do
currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest)
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
let
breadcrumbs' mcRoute = do
mr <- getMessageRender
case mcRoute of
Nothing -> return (mr MsgErrorResponseTitleNotFound, [])
Just cRoute -> do
(title, next) <- breadcrumb cRoute
crumbs <- go [] next
return (title, crumbs)
where
go crumbs Nothing = return crumbs
go crumbs (Just cRoute) = do
hasAccess <- hasReadAccessTo cRoute
(title, next) <- breadcrumb cRoute
go ((cRoute, title, hasAccess) : crumbs) next
(title, parents) <- breadcrumbs' mcurrentRoute
-- let isParent :: Route UniWorX -> Bool
-- isParent r = r == (fst parents)
@ -114,11 +96,12 @@ siteLayout' overrideHeading widget = do
now <- liftIO getCurrentTime
-- Lookup Favourites & Theme if possible
(favourites', maxFavouriteTerms, currentTheme) <- do
muid <- maybeAuthPair
-- Lookup Favourites, Breadcrumbs, & Theme if possible
(favourites', (title, parents), maxFavouriteTerms, currentTheme) <- do
muid <- maybeAuthPair
favCourses'' <- runDBRead . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
(favCourses, breadcrumbs'') <- runDBRead $ do
favCourses'' <- E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
@ -174,10 +157,30 @@ siteLayout' overrideHeading widget = do
let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView)
return ( favCourses
, maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
, maybe userDefaultTheme userTheme $ view _2 <$> muid
)
breadcrumbs''
<- let breadcrumbs' mcRoute = do
mr <- getMessageRender
case mcRoute of
Nothing -> return (mr MsgErrorResponseTitleNotFound, [])
Just cRoute -> do
(title, next) <- breadcrumb cRoute
crumbs <- go [] next
return (title, crumbs)
where
go crumbs Nothing = return crumbs
go crumbs (Just cRoute) = do
hasAccess <- hasReadAccessTo cRoute
(title, next) <- breadcrumb cRoute
go ((cRoute, title, hasAccess) : crumbs) next
in breadcrumbs' mcurrentRoute
return (favCourses, breadcrumbs'')
return ( favCourses
, breadcrumbs''
, maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
, maybe userDefaultTheme userTheme $ view _2 <$> muid
)
let favouriteTerms :: [TermIdentifier]
favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\((_, tid, _, _), _, _, _, _) -> Set.singleton $ unTermKey tid) favourites'
@ -454,7 +457,7 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
guard $ not systemMessageNewsOnly
cID <- encrypt smId
void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
guardM . lift . hasReadAccessTo $ MessageR cID
now <- liftIO getCurrentTime
guard $ NTop systemMessageFrom <= NTop (Just now)

3
src/Foundation/Yesod/ErrorHandler.hs
View File

@ -11,6 +11,7 @@ import Foundation.I18n
import Foundation.Authorization
import Foundation.SiteLayout
import Foundation.Routes
import Foundation.DB
import qualified Data.Aeson as JSON
import qualified Data.Text as Text
@ -30,7 +31,7 @@ errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
=> ErrorResponse -> HandlerFor UniWorX TypedContent
errorHandler err = do
let shouldEncrypt' = getsYesod $ view _appEncryptErrors
canDecrypt' = is _Authorized <$> evalAccess AdminErrMsgR True
canDecrypt' = runDBRead $ hasWriteAccessTo AdminErrMsgR
decrypted' <- runMaybeT $ do
internalErrorContent <- hoistMaybe $ err ^? _InternalError
exceptTMaybe $ encodedSecretBoxOpen @Text internalErrorContent

2
src/Foundation/Yesod/Middleware.hs
View File

@ -59,7 +59,7 @@ yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddlewar
case route of -- update Course Favourites here
CourseR tid ssh csh _ -> do
void . lift . runDB . runMaybeT $ do
guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
guardM . lift . hasReadAccessTo $ CourseR tid ssh csh CShowR
lift . updateFavourites $ Just (tid, ssh, csh)
_other -> return ()
normalizeRouteMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a

16
src/Foundation/Yesod/Persist.hs
View File

@ -31,10 +31,10 @@ runDB' :: ( YesodPersistBackend UniWorX ~ SqlBackend
=> CallStack -> YesodDB UniWorX a -> HandlerFor UniWorX a
runDB' lbl action = do
$logDebugS "YesodPersist" "runDB"
dryRun <- isDryRun
let action'
| dryRun = action <* transactionUndo
| otherwise = action
let action' = do
dryRun <- isDryRunDB
if | dryRun -> action <* transactionUndo
| otherwise -> action
flip (runSqlPoolRetry' action') lbl . appConnPool =<< getYesod
@ -73,10 +73,10 @@ getDBRunner' lbl = do
return . (, cleanup) $ DBRunner
(\action -> do
dryRun <- isDryRun
let action'
| dryRun = action <* transactionUndo
| otherwise = action
let action' = do
dryRun <- isDryRunDB
if | dryRun -> action <* transactionUndo
| otherwise -> action
$logDebugS "YesodPersist" "runDBRunner"
runDBRunner action'
)

2
src/Handler/ExternalExam/Form.hs
View File

@ -107,7 +107,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
fSettings = fslI MsgExternalExamStaff & setTooltip MsgExternalExamStaffTip
fRequired = True
validateExternalExam :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) => FormValidator ExternalExamForm m ()
validateExternalExam :: (MonadThrow m, MonadAP m) => FormValidator ExternalExamForm m ()
validateExternalExam = do
State.modify $ \eeForm -> eeForm & over _eefOfficeSchools (Set.delete $ eeForm ^. _eefSchool)

6
src/Handler/Info.hs
View File

@ -106,9 +106,8 @@ getGlossaryR =
mkI18nWidgetEnum "FAQ" "faq"
mkMessageFor ''UniWorX ''FAQItem "messages/faq" "de-de-formal"
faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX
faqsWidget :: ( MonadAP m
, MonadThrow m
, MonadUnliftIO m
)
=> Maybe Natural -> Maybe (Route UniWorX) -> m (Maybe Widget, Bool)
faqsWidget mLimit route = do
@ -156,9 +155,8 @@ getFaqR =
fromMaybe mempty . view _1 =<< faqsWidget Nothing Nothing
showFAQ :: ( MonadHandler m, HandlerSite m ~ UniWorX
showFAQ :: ( MonadAP m
, MonadThrow m
, MonadUnliftIO m
)
=> Route UniWorX -> FAQItem -> m Bool
showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId

10
src/Handler/Utils.hs
View File

@ -70,12 +70,12 @@ warnTermDays tid timeNames = do
-- | return a value only if the current user ist authorized for a given route
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h, MonadUnliftIO h
, MonadTrans m, MonadPlus (m (ReaderT SqlBackend h))
guardAuthorizedFor :: ( MonadThrow m
, MonadTrans t, MonadPlus (t (ReaderT SqlBackend m))
, MonadAP (ReaderT SqlBackend m)
)
=> Route UniWorX -> a -> m (ReaderT SqlBackend h) a
guardAuthorizedFor link val =
val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)
=> Route UniWorX -> a -> t (ReaderT SqlBackend m) a
guardAuthorizedFor link = guardMOn . lift $ hasReadAccessTo link
runAppLoggingT :: UniWorX -> LoggingT m a -> m a

1
src/Handler/Utils/Workflow/Workflow.hs
View File

@ -86,6 +86,7 @@ sourceWorkflowActionInfos
, BackendCompatible SqlReadBackend backend
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
, MonadCatch m, MonadUnliftIO m
, MonadAP (ReaderT backend m)
)
=> WorkflowWorkflowId
-> WorkflowState FileReference UserId

1
src/Import/NoModel.hs
View File

@ -23,6 +23,7 @@ import ClassyPrelude.Yesod as Import
, defaultYesodMiddleware
, authorizationCheck
, mkMessage, mkMessageFor, mkMessageVariant
, YesodBreadcrumbs(..)
)
import UnliftIO.Async.Utils as Import