Aggressive caching of AuthTag-Evaluation

src/Data/CaseInsensitive/Instances.hs

@@ -26,6 +26,9 @@ import qualified Database.Esqueleto as E
 
 import Web.HttpApiData
 
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
 
 instance PersistField (CI Text) where
   toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@@ -92,5 +95,9 @@ instance FromHttpApiData (CI Text) where
 
 instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
   fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
-  toPathMultiPiece = toPathMultiPiece . CI.foldedCase
+  toPathMultiPiece = toPathMultiPiece . CI.original
 
+instance (CI.FoldCase s, Binary s) => Binary (CI s) where
+  get = CI.mk <$> Binary.get
+  put = Binary.put . CI.original
+  putList = Binary.putList . map CI.original

src/Foundation.hs

@@ -46,7 +46,7 @@ import Data.Map (Map, (!?))
 import qualified Data.Map as Map
 import qualified Data.HashSet as HashSet
 
-import Data.List (nubBy, (!!))
+import Data.List (nubBy, (!!), findIndex)
 
 import Data.Monoid (Any(..))
 
@@ -493,7 +493,7 @@ askTokenUnsafe = $cachedHere $ do
       throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
 
 validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult
-validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token'
+validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token'
   where
     validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult
     validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
@@ -524,7 +524,7 @@ tagAccessPredicate :: AuthTag -> AccessPredicate
 tagAccessPredicate AuthFree = trueAP
 tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
   -- Courses: access only to school admins
-  CourseR tid ssh csh _ -> exceptT return return $ do
+  CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
       E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
@@ -536,7 +536,7 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
     guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
     return Authorized
   -- other routes: access to any admin is granted here
-  _other -> exceptT return return $ do
+  _other -> $cachedHereBinary mAuthId . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
@@ -566,7 +566,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
   return $ Unauthorized "Route under development"
 #endif
 tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
-  CourseR tid ssh csh _ -> exceptT return return $ do
+  CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
        E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
@@ -578,13 +578,13 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
      guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
      return Authorized
   -- lecturer for any school will do
-  _ -> exceptT return return $ do
+  _ -> $cachedHereBinary mAuthId . exceptT return return $ do
      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
      void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
      return Authorized
 tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
   authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-  resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
+  resList <- $cachedHereBinary (mAuthId) . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
     E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
     E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
     E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
@@ -593,17 +593,17 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
     resMap :: Map CourseId (Set SheetId)
     resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
   case route of
-    CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
+    CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
       sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
       Submission{..} <- MaybeT . lift $ get sid
       guard $ maybe False (== authId) submissionRatingBy
       return Authorized
-    CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
+    CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
       Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
       Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
       guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
       return Authorized
-    CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
+    CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
       Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
       guard $ cid `Set.member` Map.keysSet resMap
       return Authorized
@@ -636,10 +636,10 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return
 tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
   CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do
     now <- liftIO getCurrentTime
-    course <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-    Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial course tutn
+    Entity tutId Tutorial{..} <- $cachedHereBinary (course, tutn) . MaybeT . getBy $ UniqueTutorial course tutn
     registered <- case mAuthId of
-      Just uid -> lift . existsBy $ UniqueTutorialParticipant tutId uid
+      Just uid -> $cachedHereBinary (tutId, uid) . lift . existsBy $ UniqueTutorialParticipant tutId uid
       Nothing  -> return False
 
     if
@@ -654,8 +654,8 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
         -> mzero
 
   CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
-    cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-    Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
+    Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
     cTime <- liftIO getCurrentTime
     let
       visible = NTop sheetVisibleFrom <= NTop (Just cTime)
@@ -684,8 +684,8 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
     return Authorized
 
   CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do
-    cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-    Entity _mid Material{materialVisibleFrom} <- MaybeT . getBy $ UniqueMaterial cid mnm
+    Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm
     cTime <- liftIO getCurrentTime
     let visible = NTop materialVisibleFrom <= NTop (Just cTime)
     guard visible
@@ -693,9 +693,9 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
 
   CourseR tid ssh csh CRegisterR -> do
     now <- liftIO getCurrentTime
-    mbc <- getBy $ TermSchoolCourseShort tid ssh csh
+    mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
     registered <- case (mbc,mAuthId) of
-      (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid)
+      (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ isJust <$> (getBy $ UniqueParticipant uid cid)
       _ -> return False
     case mbc of
       (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
@@ -709,7 +709,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
 
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
     smId <- decrypt cID
-    SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId
+    SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
     cTime <- (NTop . Just) <$> liftIO getCurrentTime
     guard $ NTop systemMessageFrom <= cTime
          && NTop systemMessageTo   >= cTime
@@ -865,21 +865,21 @@ tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
     return Authorized
   r -> $unsupportedAuthPredicate AuthMaterials r
 tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
-  CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
+  CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
     sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
     return Authorized
   r -> $unsupportedAuthPredicate AuthOwner r
 tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
-  CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
+  CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
     sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
     sub <- MaybeT $ get sid
     guard $ submissionRatingDone sub
     return Authorized
   r -> $unsupportedAuthPredicate AuthRated r
 tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
-  CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
+  CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
     guard $ is _Just submissionModeUser
@@ -918,6 +918,21 @@ tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorize
 tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
 
 
+authTagSpecificity :: AuthTag -> AuthTag -> Ordering
+-- ^ Heuristic for which `AuthTag`s to evaluate first
+authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem
+  where
+    eqClasses :: [[AuthTag]]
+    -- ^ Constructors of `AuthTag` ordered (increasing) by execution order
+    eqClasses =
+      [ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide
+      , [ AuthRead, AuthWrite, AuthToken ] -- Request wide
+      , [ AuthAdmin ] -- Site wide
+      , [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide
+      , [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide
+      , [ AuthOwner, AuthRated ] -- Submission wide
+      ]
+
 defaultAuthDNF :: AuthDNF
 defaultAuthDNF = PredDNF $ Set.fromList
   [ impureNonNull . Set.singleton $ PLVariable AuthAdmin
@@ -945,16 +960,19 @@ routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partiti
 
 evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
 -- ^ `tell`s disabled predicates, identified as pivots
-evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite
+evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
   = do
       mr <- getMsgRenderer
       let
+        authVarSpecificity = authTagSpecificity `on` plVar
+        authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF'
+        
         authTagIsInactive = not . authTagIsActive
 
         evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
-        evalAuthTag authTag = lift . (runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
+        evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
           where
-            evalAccessPred' authTag' mAuthId' route' isWrite' = CachedMemoT $ do
+            evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
               $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
               evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
 

src/Import/NoModel.hs

@@ -14,7 +14,7 @@ import Yesod.Auth             as Import
 import Yesod.Core.Types       as Import (loggerSet)
 import Yesod.Default.Config2  as Import
 import Yesod.Core.Json        as Import (provideJson)
-import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
+import Yesod.Core.Types.Instances as Import
 
 import Utils                  as Import
 import Utils.Frontend.I18n    as Import

src/Utils.hs

@@ -69,6 +69,7 @@ import qualified Crypto.Data.PKCS7 as PKCS7
 import Data.Fixed
 import Data.Ratio ((%))
 
+import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
 import Network.Wai (requestMethod)
@@ -914,10 +915,18 @@ encodedSecretBoxOpen ciphertext = do
 -- Caching --
 -------------
 
+cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b
+cachedByBinary k = cachedBy (toStrict $ Binary.encode k)
+
 cachedHere :: Q Exp
 cachedHere = do
   loc <- location
-  [e| cachedBy (toStrict $ Binary.encode loc) |]
+  [e| cachedByBinary loc |]
+
+cachedHereBinary :: Q Exp
+cachedHereBinary = do
+  loc <- location
+  [e| \k -> cachedByBinary (loc, k) |]
 
 hashToText :: Hashable a => a -> Text
 hashToText = decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash

src/Yesod/Core/Types/Instances.hs

@@ -2,7 +2,8 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
 
 module Yesod.Core.Types.Instances
-  ( CachedMemoT(..)
+  ( CachedMemoT
+  , runCachedMemoT
   ) where
 
 import ClassyPrelude.Yesod
@@ -13,9 +14,15 @@ import Control.Monad.Fix
 import Control.Monad.Memo
 
 import Data.Binary (Binary)
-import qualified Data.Binary as Binary
 
 import Control.Monad.Logger (MonadLoggerIO)
+
+import Utils
+
+import Language.Haskell.TH
+
+import Control.Monad.Reader (MonadReader(..))
+import Control.Monad.Trans.Reader (ReaderT, mapReaderT, runReaderT)
   
 
 instance MonadFix m => MonadFix (HandlerT site m) where
@@ -26,23 +33,31 @@ instance MonadFix m => MonadFix (WidgetT site m) where
 
 
 -- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo`
-newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT :: m a }
+newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a }
   deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix
                    , MonadIO
                    , MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO
                    , MonadResource, MonadHandler, MonadWidget
-                   , IsString, Semigroup, Monoid
                    )
 
 deriving newtype instance MonadBase b m => MonadBase b (CachedMemoT k v m)
 deriving newtype instance MonadBaseControl b m => MonadBaseControl b (CachedMemoT k v m)
 
-deriving newtype instance MonadReader r m => MonadReader r (CachedMemoT k v m)
+instance MonadReader r m => MonadReader r (CachedMemoT k v m) where
+  reader = CachedMemoT . lift . reader
+  local f (CachedMemoT act) = CachedMemoT $ mapReaderT (local f) act
 
 instance MonadTrans (CachedMemoT k v) where
-  lift = CachedMemoT
+  lift = CachedMemoT . lift
 
 
 -- | Uses `cachedBy` with a `Binary`-encoded @k@
 instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where
-  memo act key = cachedBy (toStrict $ Binary.encode key) $ act key
+  memo act key = do
+    loc <- CachedMemoT ask
+    cachedByBinary (loc, key) $ act key
+
+runCachedMemoT :: Q Exp
+runCachedMemoT = do
+  loc <- location
+  [e| flip runReaderT loc . runCachedMemoT' |]