From 2f85cea1deb8827fd5bce848b4b4c798adb2de19 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Mar 2021 17:35:40 +0100 Subject: [PATCH] perf: reduce db-conn-load of tokens --- src/Foundation/Authorization.hs | 129 ++++++++++++++++++++----------- src/Foundation/Instances.hs | 8 +- src/Handler/Submission/Helper.hs | 2 +- 3 files changed, 90 insertions(+), 49 deletions(-) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 2dbf35ae6..0b618f1f4 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -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 diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 5a997f8e4..6c43332ee 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -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 diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index d85afd934..a148b289a 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -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