perf: try to reduce db-conn-load of cached auth

src/Foundation/Authorization.hs

@@ -99,7 +99,7 @@ data AccessPredicate
   | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
   | APDB       (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
   | APBind     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either AccessPredicate AuthResult))
-  | APBindDB   (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) (Either AccessPredicate AuthResult))
+  | APBindDB   (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either (ReaderT SqlReadBackend (HandlerFor UniWorX) (Either AccessPredicate AuthResult)) (Either AccessPredicate AuthResult)))
 
 class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where
   evalAccessPred :: AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
@@ -121,12 +121,9 @@ instance ( BearerAuthSite UniWorX
     (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
     (APHandler p) -> p aid r w
     (APDB      p) -> apRunDB $ p contCtx cont aid r w
-    (APBind    p) -> do
+    (APBind    p) -> evalAccessPred (APBindDB $ \aid' r' w' -> Right <$> p aid' r' w') contCtx cont aid r w
-      res <- p aid r w
+    (APBindDB  p) -> let contAP p' = evalAccessPred p' contCtx cont aid r w
-      case res of
+                      in p aid r w >>= either apRunDB return >>= either contAP return
-        Right res' -> return res'
-        Left p' -> evalAccessPred p' 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
@@ -143,56 +140,67 @@ instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBack
     (APPure    p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
     (APHandler p) -> lift $ p aid r w
     (APDB      p) -> p contCtx cont aid r w
-    (APBind    p) -> evalAccessPred (APBindDB $ \aid' r' w' -> lift $ p aid' r' w') contCtx cont aid r w
+    (APBind    p) -> evalAccessPred (APBindDB $ \aid' r' w' -> Right <$> p aid' r' w') contCtx cont aid r w
-    (APBindDB  p) -> do
+    (APBindDB  p) -> let contAP p' = evalAccessPred p' contCtx cont aid r w
-      res <- p aid r w
+                      in lift (p aid r w) >>= either id return >>= either contAP return
-      case res of
-        Right res' -> return res'
-        Left p' -> evalAccessPred p' contCtx cont aid r w
 
   apRunDB = hoist liftHandler . withReaderT projectBackend
 
-cacheAP :: ( Binary k
+-- cacheAP :: ( Binary k
-           , Typeable v, Binary v
+--            , Typeable v, Binary v
-           )
+--            )
-        => Maybe Expiry
+--         => Maybe Expiry
-        -> k
+--         -> k
-        -> HandlerFor UniWorX v
+--         -> HandlerFor UniWorX v
-        -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
+--         -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
-        -> AccessPredicate
+--         -> AccessPredicate
-cacheAP mExp k mkV cont = APBind $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV
+-- cacheAP mExp k mkV cont = APBind $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV
 
--- cacheAPDB :: ( Binary k
+cacheAPDB :: ( Binary k
---              , Typeable v, Binary v
+             , Typeable v, Binary v
---              )
+             )
---           => Maybe Expiry
+          => Maybe Expiry
---           -> k
+          -> k
---           -> ReaderT SqlReadBackend (HandlerFor UniWorX) v
+          -> ReaderT SqlReadBackend (HandlerFor UniWorX) v
---           -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult))
+          -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
---           -> AccessPredicate
+          -> AccessPredicate
--- cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV
+cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do
+  cachedV <- memcachedByGet k
+  case cachedV of
+    Just v -> fmap Right . either (return . Left) (fmap Right) $ cont mAuthId route isWrite v
+    Nothing -> return . Left $ do
+      v <- mkV
+      memcachedBySet mExp k v
+      either (return . Left) (fmap Right . lift) $ cont mAuthId route isWrite v
  
-cacheAP' :: ( Binary k
+-- cacheAP' :: ( Binary k
-            , Typeable v, Binary v
+--             , Typeable v, Binary v
-            )
+--             )
-         => Maybe Expiry
+--          => Maybe Expiry
-         -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, HandlerFor UniWorX v))
+--          -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, HandlerFor UniWorX v))
-         -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
+--          -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
-         -> AccessPredicate
+--          -> AccessPredicate
-cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
+-- cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
-  Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV
-  Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing
-  
--- cacheAPDB' :: ( Binary k
---               , Typeable v, Binary v
---               )
---            => Maybe Expiry
---            -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, ReaderT SqlReadBackend (HandlerFor UniWorX) v))
---            -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult))
---            -> AccessPredicate
--- cacheAPDB' mExp mkKV cont = APBindDB $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
 --   Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV
 --   Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing
+  
+cacheAPDB' :: ( Binary k
+              , Typeable v, Binary v
+              )
+           => Maybe Expiry
+           -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, ReaderT SqlReadBackend (HandlerFor UniWorX) v))
+           -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
+           -> AccessPredicate
+cacheAPDB' mExp mkKV cont = APBindDB $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
+  Just (k, mkV) -> do
+    cachedV <- memcachedByGet k
+    case cachedV of
+      Just v -> fmap Right . either (return . Left) (fmap Right) . cont mAuthId route isWrite $ Just v
+      Nothing -> return . Left $ do
+        v <- mkV
+        memcachedBySet mExp k v
+        either (return . Left) (fmap Right . lift) . cont mAuthId route isWrite $ Just v
+  Nothing -> fmap Right . either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing
 
 
 orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
@@ -472,9 +480,9 @@ cacheAPSchoolFunction :: BearerAuthSite UniWorX
                       -> Maybe Expiry
                       -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Set (AuthId UniWorX) -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
                       -> AccessPredicate
-cacheAPSchoolFunction f mExp = cacheAP mExp (AuthCacheSchoolFunctionList f) mkFunctionList
+cacheAPSchoolFunction f mExp = cacheAPDB mExp (AuthCacheSchoolFunctionList f) mkFunctionList
   where
-    mkFunctionList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do
+    mkFunctionList = fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do
       E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val f
       return $ userFunction E.^. UserFunctionUser
 
@@ -483,9 +491,9 @@ cacheAPSystemFunction :: BearerAuthSite UniWorX
                       -> Maybe Expiry
                       -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Set (AuthId UniWorX) -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
                       -> AccessPredicate
-cacheAPSystemFunction f mExp = cacheAP mExp (AuthCacheSystemFunctionList f) mkFunctionList
+cacheAPSystemFunction f mExp = cacheAPDB mExp (AuthCacheSystemFunctionList f) mkFunctionList
   where
-    mkFunctionList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ \userSystemFunction -> do
+    mkFunctionList = fmap (setOf $ folded . _Value) . E.select . E.from $ \userSystemFunction -> do
       E.where_ $ userSystemFunction E.^. UserSystemFunctionFunction E.==. E.val f
            E.&&. E.not_ (userSystemFunction E.^. UserSystemFunctionIsOptOut)
       return $ userSystemFunction E.^. UserSystemFunctionUser
@@ -672,7 +680,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
   return $ Unauthorized "Route under development"
 #endif
 
-tagAccessPredicate AuthLecturer = cacheAP' (Just $ Right diffMinute) mkLecturerList $ \mAuthId' route' _ mLecturerList -> if
+tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecturerList $ \mAuthId' route' _ mLecturerList -> if
   | Just lecturerList <- mLecturerList
   , maybe True (`Set.notMember` lecturerList) mAuthId' -> Right $ case route' of
       _ | is _Nothing mAuthId' -> return AuthenticationRequired
@@ -725,20 +733,20 @@ tagAccessPredicate AuthLecturer = cacheAP' (Just $ Right diffMinute) mkLecturerL
       AllocationR{} -> cacheLecturerList 
       EExamR{} -> Just
         ( AuthCacheExternalExamStaffList
-        , runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser)
+        , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser)
         )
       _other -> Just
         ( AuthCacheSchoolFunctionList SchoolLecturer
-        , runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do
+        , fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do
             E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolLecturer
             return $ userFunction E.^. UserFunctionUser
         )
       where
         cacheLecturerList = Just
           ( AuthCacheLecturerList
-          , runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser)
+          , fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser)
           )
-tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCorrectorList mkCorrectorList $ \mAuthId' route' _ correctorList -> if
+tagAccessPredicate AuthCorrector = cacheAPDB (Just $ Right diffMinute) AuthCacheCorrectorList mkCorrectorList $ \mAuthId' route' _ correctorList -> if
   | maybe True (`Set.notMember` correctorList) mAuthId' -> Right $ case route' of
       _ | is _Nothing mAuthId' -> return AuthenticationRequired
       CSubmissionR{} -> unauthorizedI MsgUnauthorizedSubmissionCorrector
@@ -778,12 +786,12 @@ tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCo
             E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
           return Authorized
   where
-    mkCorrectorList = runDBRead . execWriterT $ do
+    mkCorrectorList = execWriterT $ do
       tellM . fmap (setOf $ folded . _Value . _Just) . E.select . E.from $ \submission -> do
         E.where_ . E.isJust $ submission E.^. SubmissionRatingBy
         return $ submission E.^. SubmissionRatingBy
       tellM . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. SheetCorrectorUser)
-tagAccessPredicate AuthExamCorrector = cacheAP (Just $ Right diffMinute) AuthCacheExamCorrectorList mkExamCorrectorList $ \mAuthId' route' _ examCorrectorList -> if
+tagAccessPredicate AuthExamCorrector = cacheAPDB (Just $ Right diffMinute) AuthCacheExamCorrectorList mkExamCorrectorList $ \mAuthId' route' _ examCorrectorList -> if
   | maybe True (`Set.notMember` examCorrectorList) mAuthId' -> Right $ case route' of
       _ | is _Nothing mAuthId' -> return AuthenticationRequired
       CExamR{} -> unauthorizedI MsgUnauthorizedExamCorrector
@@ -815,8 +823,8 @@ tagAccessPredicate AuthExamCorrector = cacheAP (Just $ Right diffMinute) AuthCac
         return Authorized
       r -> $unsupportedAuthPredicate AuthExamCorrector r
   where
-    mkExamCorrectorList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser)
+    mkExamCorrectorList = fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser)
-tagAccessPredicate AuthTutor = cacheAP (Just $ Right diffMinute) AuthCacheTutorList mkTutorList $ \mAuthId' route' _ tutorList -> if
+tagAccessPredicate AuthTutor = cacheAPDB (Just $ Right diffMinute) AuthCacheTutorList mkTutorList $ \mAuthId' route' _ tutorList -> if
   | maybe True (`Set.notMember` tutorList) mAuthId' -> Right $ case route' of
       _ | is _Nothing mAuthId' -> return AuthenticationRequired
       CTutorialR{} -> unauthorizedI MsgUnauthorizedTutorialTutor
@@ -846,7 +854,7 @@ tagAccessPredicate AuthTutor = cacheAP (Just $ Right diffMinute) AuthCacheTutorL
           guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
           return Authorized
   where
-    mkTutorList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. TutorUser)
+    mkTutorList = fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. TutorUser)
 tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of
   CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do
     Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
@@ -1151,7 +1159,7 @@ tagAccessPredicate AuthExamTime = APDB $ \_ _ _ route _ -> case route of
       guard $ NTop (Just now) >= NTop examFinished
     return Authorized
   r -> $unsupportedAuthPredicate AuthExamTime r
-tagAccessPredicate AuthCourseRegistered = cacheAP' (Just $ Right diffMinute) mkAuthCacheCourseRegisteredList $ \mAuthId' route' _ mCourseRegisteredList -> if
+tagAccessPredicate AuthCourseRegistered = cacheAPDB' (Just $ Right diffMinute) mkAuthCacheCourseRegisteredList $ \mAuthId' route' _ mCourseRegisteredList -> if
   | Just courseRegisteredList <- mCourseRegisteredList
   , maybe True (`Set.notMember` courseRegisteredList) mAuthId' -> Right $ case route' of
       _ | is _Nothing mAuthId' -> return AuthenticationRequired
@@ -1174,7 +1182,7 @@ tagAccessPredicate AuthCourseRegistered = cacheAP' (Just $ Right diffMinute) mkA
     mkAuthCacheCourseRegisteredList _ route _ = case route of
       CourseR tid ssh csh _ -> Just
         ( AuthCacheCourseRegisteredList tid ssh csh
-        , runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
+        , fmap (setOf $ folded . _Value) . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
             E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
             E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
                  E.&&. course E.^. CourseTerm      E.==. E.val tid