perf: reduce db-conn-load of tokens

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
+  isWrite <- liftHandler $ isWriteRequest currentRoute
-  guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer
+  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
+requireCurrentBearerRestrictions = runMaybeT $ do
-  bearer <- requireBearerToken
+  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

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

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