Aggressive caching of AuthTag-Evaluation
This commit is contained in:
Gregor Kleen
parent
745feeac83
commit
3dc66c4817
@ -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
|
||||
|
||||
@ -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
|
||||
Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial course tutn
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
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
|
||||
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
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
|
||||
Entity _mid Material{materialVisibleFrom} <- MaybeT . getBy $ UniqueMaterial cid mnm
|
||||
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
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'
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
11
src/Utils.hs
11
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
|
||||
|
||||
@ -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' |]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user