perf: try to reduce db connection load of auth

src/Foundation/Authorization.hs

@@ -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
+type family DisabledMonadAPInstance t err :: Constraint where
-  evalAccessPred aPred contCtx cont aid r w = liftHandler $ case aPred of
+  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.
+newtype IsDryRun = MkIsDryRun { unIsDryRun :: Bool }
-            ( HasCallStack
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-            , MonadHandler m, HandlerSite m ~ UniWorX
+
+isDryRun :: ( HasCallStack
             , BearerAuthSite UniWorX
             )
-         => m Bool
+         => HandlerFor UniWorX Bool
-isDryRun = $cachedHere . liftHandler $ orM
+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
+    bearerRequired = maybeT (return True) . catchIfMaybeT cPred $ do
-      mAuthId <- defaultMaybeAuthId
+      mAuthId <- liftHandler defaultMaybeAuthId
-      currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
+      currentRoute <- liftHandler $ maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
-      isWrite <- isWriteRequest currentRoute
+      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

src/Foundation/Instances.hs

@@ -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
 

src/Foundation/SiteLayout.hs

@@ -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
+  -- Lookup Favourites, Breadcrumbs, & Theme if possible
-  (favourites', maxFavouriteTerms, currentTheme) <- do
+  (favourites', (title, parents), maxFavouriteTerms, currentTheme) <- do
-      muid <- maybeAuthPair
+    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
+      breadcrumbs''
-             , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
+        <- let breadcrumbs' mcRoute = do
-             , maybe userDefaultTheme userTheme $ view _2 <$> muid
+                 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)

src/Foundation/Yesod/ErrorHandler.hs

@@ -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

src/Foundation/Yesod/Middleware.hs

@@ -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

src/Foundation/Yesod/Persist.hs

@@ -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' = do
-  let action'
+        dryRun <- isDryRunDB
-        | dryRun = action <* transactionUndo
+        if | dryRun    -> action <* transactionUndo
-        | otherwise = action
+           | otherwise -> action
 
   flip (runSqlPoolRetry' action') lbl . appConnPool =<< getYesod
 
@@ -73,10 +73,10 @@ getDBRunner' lbl = do
 
   return . (, cleanup) $ DBRunner
     (\action -> do
-        dryRun <- isDryRun
+        let action' = do
-        let action'
+              dryRun <- isDryRunDB
-              | dryRun = action <* transactionUndo
+              if | dryRun    -> action <* transactionUndo
-              | otherwise = action
+                 | otherwise -> action
         $logDebugS "YesodPersist" "runDBRunner"
         runDBRunner action'
     )

src/Handler/ExternalExam/Form.hs

@@ -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)
 

src/Handler/Info.hs

@@ -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

src/Handler/Utils.hs

@@ -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
+guardAuthorizedFor :: ( MonadThrow m
-                      , MonadTrans m, MonadPlus (m (ReaderT SqlBackend h))
+                      , MonadTrans t, MonadPlus (t (ReaderT SqlBackend m))
+                      , MonadAP (ReaderT SqlBackend m)
                       )
-  => Route UniWorX -> a -> m (ReaderT SqlBackend h) a
+                   => Route UniWorX -> a -> t (ReaderT SqlBackend m) a
-guardAuthorizedFor link val =
+guardAuthorizedFor link = guardMOn . lift $ hasReadAccessTo link
-  val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)
 
 
 runAppLoggingT :: UniWorX -> LoggingT m a -> m a

src/Handler/Utils/Workflow/Workflow.hs

@@ -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

src/Import/NoModel.hs

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