refactor(memcached): remove ARC cache entirely
NOTE: this was a crude surgery, removing everything ARC related; some dead code artifacts may have remained. Especially check PrewarmCacheConf Reason for removall: adding `memcachedInvalidateClass` was difficult to implement with ARC active; ARC was known to be problematic; removal was easier (see #2 2024-09-23)
This commit is contained in:
parent
74c330bd24
commit
e757209b80
@ -206,9 +206,6 @@ memcached:
|
||||
timeout: "_env:MEMCACHED_TIMEOUT:20"
|
||||
expiration: "_env:MEMCACHED_EXPIRATION:300"
|
||||
memcache-auth: true
|
||||
memcached-local:
|
||||
maximum-ghost: 512
|
||||
maximum-weight: 104857600 # 100MiB
|
||||
|
||||
upload-cache:
|
||||
host: "_env:UPLOAD_S3_HOST:localhost" # should be optional, but all file transfers will be empty without an S3 cache
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -119,9 +119,6 @@ import qualified Data.IntervalMap.Strict as IntervalMap
|
||||
|
||||
import qualified Utils.Pool as Custom
|
||||
|
||||
import Utils.Postgresql
|
||||
import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
|
||||
|
||||
import qualified System.Clock as Clock
|
||||
|
||||
import Utils.Avs (mkAvsQuery)
|
||||
@ -219,10 +216,6 @@ makeFoundation appSettings''@AppSettings{..} = do
|
||||
appJobState <- liftIO newEmptyTMVarIO
|
||||
appHealthReport <- liftIO $ newTVarIO Set.empty
|
||||
|
||||
appFileSourceARC <- for appFileSourceARCConf $ \ARCConf{..} -> do
|
||||
ah <- initARCHandle arccMaximumGhost arccMaximumWeight
|
||||
void . Prometheus.register $ arcMetrics ARCFileSource ah
|
||||
return ah
|
||||
appFileSourcePrewarm <- for appFileSourcePrewarmConf $ \PrewarmCacheConf{..} -> do
|
||||
lh <- initLRUHandle precMaximumWeight
|
||||
void . Prometheus.register $ lruMetrics LRUFileSourcePrewarm lh
|
||||
@ -239,7 +232,7 @@ makeFoundation appSettings''@AppSettings{..} = do
|
||||
-- from there, and then create the real foundation.
|
||||
let
|
||||
mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _
|
||||
mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
|
||||
mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..}
|
||||
tempFoundation = mkFoundation
|
||||
(error "appSettings' forced in tempFoundation")
|
||||
(error "connPool forced in tempFoundation")
|
||||
@ -252,7 +245,6 @@ makeFoundation appSettings''@AppSettings{..} = do
|
||||
(error "JSONWebKeySet forced in tempFoundation")
|
||||
(error "ClusterID forced in tempFoundation")
|
||||
(error "memcached forced in tempFoundation")
|
||||
(error "memcachedLocal forced in tempFoundation")
|
||||
(error "MinioConn forced in tempFoundation")
|
||||
(error "VerpSecret forced in tempFoundation")
|
||||
(error "AuthKey forced in tempFoundation")
|
||||
@ -337,12 +329,6 @@ makeFoundation appSettings''@AppSettings{..} = do
|
||||
$logWarnS "setup" "Clearing memcached"
|
||||
liftIO $ Memcached.flushAll memcachedConn
|
||||
return AppMemcached{..}
|
||||
appMemcachedLocal <- for appMemcachedLocalConf $ \ARCConf{..} -> do
|
||||
memcachedLocalARC <- initARCHandle arccMaximumGhost arccMaximumWeight
|
||||
void . Prometheus.register $ arcMetrics ARCMemcachedLocal memcachedLocalARC
|
||||
memcachedLocalInvalidationQueue <- newTVarIO mempty
|
||||
memcachedLocalHandleInvalidations <- allocateLinkedAsync . managePostgresqlChannel appDatabaseConf ChannelMemcachedLocalInvalidation $ manageMemcachedLocalInvalidations memcachedLocalARC memcachedLocalInvalidationQueue
|
||||
return AppMemcachedLocal{..}
|
||||
|
||||
appSessionStore <- mkSessionStore appSettings'' sqlPool `customRunSqlPool` sqlPool
|
||||
|
||||
@ -380,7 +366,7 @@ makeFoundation appSettings''@AppSettings{..} = do
|
||||
|
||||
$logDebugS "Runtime configuration" $ tshowCrop appSettings'
|
||||
|
||||
let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
|
||||
let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
|
||||
|
||||
-- Return the foundation
|
||||
$logInfoS "setup" "*** DONE ***"
|
||||
|
||||
@ -313,7 +313,8 @@ isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM
|
||||
|
||||
dnf <- throwLeft $ routeAuthTags currentRoute
|
||||
let eval :: forall m''. MonadAP m'' => AuthTagsEval m''
|
||||
eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
|
||||
-- eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
|
||||
eval dnf' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf')
|
||||
in guardAuthResult <=< evalWriterT $ eval dnf mAuthId currentRoute isWrite
|
||||
|
||||
return False
|
||||
@ -368,7 +369,8 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
|
||||
noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
|
||||
|
||||
eval :: forall m'. MonadAP m' => AuthTagsEval m'
|
||||
eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite''
|
||||
-- eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite''
|
||||
eval dnf' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf')
|
||||
|
||||
bearerAuthority' <- hoist apRunDB $ do
|
||||
bearerAuthority' <- flip foldMapM bearerAuthority $ \case
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -11,8 +11,6 @@ module Foundation.Type
|
||||
, _SessionStorageMemcachedSql, _SessionStorageAcid
|
||||
, AppMemcached(..)
|
||||
, _memcachedKey, _memcachedConn
|
||||
, AppMemcachedLocal(..)
|
||||
, _memcachedLocalARC
|
||||
, SMTPPool
|
||||
, _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery
|
||||
, DB, DBRead, Form, MsgRenderer, MailM, DBFile
|
||||
@ -38,9 +36,6 @@ import qualified Utils.Pool as Custom
|
||||
|
||||
import Utils.Metrics (DBConnUseState)
|
||||
|
||||
import qualified Data.ByteString.Lazy as Lazy
|
||||
import Data.Time.Clock.POSIX (POSIXTime)
|
||||
import GHC.Fingerprint (Fingerprint)
|
||||
import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey)
|
||||
|
||||
import Utils.Avs (AvsQuery())
|
||||
@ -62,13 +57,6 @@ data AppMemcached = AppMemcached
|
||||
|
||||
makeLenses_ ''AppMemcached
|
||||
|
||||
data AppMemcachedLocal = AppMemcachedLocal
|
||||
{ memcachedLocalARC :: ARCHandle (Fingerprint, Lazy.ByteString) Int (NFDynamic, Maybe POSIXTime)
|
||||
, memcachedLocalHandleInvalidations :: Async ()
|
||||
, memcachedLocalInvalidationQueue :: TVar (Seq (Fingerprint, Lazy.ByteString))
|
||||
} deriving (Generic)
|
||||
|
||||
makeLenses_ ''AppMemcachedLocal
|
||||
|
||||
-- | The foundation datatype for your application. This can be a good place to
|
||||
-- keep settings and values requiring initialization before your application
|
||||
@ -93,11 +81,9 @@ data UniWorX = UniWorX
|
||||
, appJSONWebKeySet :: Jose.JwkSet
|
||||
, appHealthReport :: TVar (Set (UTCTime, HealthReport))
|
||||
, appMemcached :: Maybe AppMemcached
|
||||
, appMemcachedLocal :: Maybe AppMemcachedLocal
|
||||
, appUploadCache :: Maybe MinioConn
|
||||
, appVerpSecret :: VerpSecret
|
||||
, appAuthKey :: Auth.Key
|
||||
, appFileSourceARC :: Maybe (ARCHandle (FileContentChunkReference, (Int, Int)) Int ByteString)
|
||||
, appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString)
|
||||
, appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference))
|
||||
, appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -26,7 +26,7 @@ import Handler.Utils.I18n as Handler.Utils
|
||||
import Handler.Utils.Widgets as Handler.Utils
|
||||
import Handler.Utils.Database as Handler.Utils
|
||||
import Handler.Utils.Occurrences as Handler.Utils
|
||||
import Handler.Utils.Memcached as Handler.Utils hiding (manageMemcachedLocalInvalidations)
|
||||
import Handler.Utils.Memcached as Handler.Utils
|
||||
import Handler.Utils.Files as Handler.Utils
|
||||
import Handler.Utils.Download as Handler.Utils
|
||||
import Handler.Utils.AuthorshipStatement as Handler.Utils
|
||||
|
||||
@ -222,7 +222,7 @@ avsQueryNoCacheDefault qry = do
|
||||
qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
|
||||
throwLeftM $ qfun qry
|
||||
|
||||
avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q), NFData (SomeAvsResponse q)
|
||||
avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q)
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
|
||||
avsQueryCached qry =
|
||||
getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -18,8 +18,6 @@ import Foundation.Type
|
||||
import Foundation.DB
|
||||
import Utils.Metrics
|
||||
|
||||
import Data.Monoid (First(..))
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import qualified Data.Conduit.List as C (unfoldM)
|
||||
|
||||
@ -32,7 +30,6 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import System.FilePath (normalise, makeValid)
|
||||
import Data.List (dropWhileEnd)
|
||||
|
||||
import qualified Data.ByteString as ByteString
|
||||
|
||||
|
||||
data SourceFilesException
|
||||
@ -44,58 +41,36 @@ data SourceFilesException
|
||||
makePrisms ''SourceFilesException
|
||||
|
||||
|
||||
fileChunkARC :: ( MonadHandler m
|
||||
fileChunk :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Maybe Int
|
||||
-> (FileContentChunkReference, (Int, Int))
|
||||
=> (FileContentChunkReference, (Int, Int))
|
||||
-> m (Maybe (ByteString, Maybe FileChunkStorage))
|
||||
-> m (Maybe ByteString)
|
||||
fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do
|
||||
fileChunk k getChunkDB' = do
|
||||
prewarm <- getsYesod appFileSourcePrewarm
|
||||
let getChunkDB = case prewarm of
|
||||
-- NOTE: crude surgery happened here to remove ARC caching; useless artifacts may have remained
|
||||
case prewarm of
|
||||
Nothing -> do
|
||||
chunk' <- getChunkDB'
|
||||
for chunk' $ \(chunk, mStorage) -> chunk <$ do
|
||||
$logDebugS "fileChunkARC" "No prewarm"
|
||||
for_ mStorage $ \storage ->
|
||||
let w = length chunk
|
||||
in liftIO $ observeSourcedChunk storage w
|
||||
Just lh -> do
|
||||
chunkRes <- lookupLRUHandle lh k
|
||||
case chunkRes of
|
||||
Just (chunk, w) -> Just chunk <$ do
|
||||
$logDebugS "fileChunkARC" "Prewarm hit"
|
||||
liftIO $ observeSourcedChunk StoragePrewarm w
|
||||
Nothing -> do
|
||||
chunk' <- getChunkDB'
|
||||
for chunk' $ \(chunk, mStorage) -> chunk <$ do
|
||||
$logDebugS "fileChunkARC" "No prewarm"
|
||||
$logDebugS "fileChunkARC" "Prewarm miss"
|
||||
for_ mStorage $ \storage ->
|
||||
let w = length chunk
|
||||
in liftIO $ observeSourcedChunk storage w
|
||||
Just lh -> do
|
||||
chunkRes <- lookupLRUHandle lh k
|
||||
case chunkRes of
|
||||
Just (chunk, w) -> Just chunk <$ do
|
||||
$logDebugS "fileChunkARC" "Prewarm hit"
|
||||
liftIO $ observeSourcedChunk StoragePrewarm w
|
||||
Nothing -> do
|
||||
chunk' <- getChunkDB'
|
||||
for chunk' $ \(chunk, mStorage) -> chunk <$ do
|
||||
$logDebugS "fileChunkARC" "Prewarm miss"
|
||||
for_ mStorage $ \storage ->
|
||||
let w = length chunk
|
||||
in liftIO $ observeSourcedChunk storage w
|
||||
|
||||
arc <- getsYesod appFileSourceARC
|
||||
case arc of
|
||||
Nothing -> getChunkDB
|
||||
Just ah -> do
|
||||
cachedARC' ah k $ \case
|
||||
Nothing -> do
|
||||
chunk' <- case assertM (> l) altSize of
|
||||
-- This optimization works for the somewhat common case that cdc chunks are smaller than db chunks and start of the requested range is aligned with a db chunk boundary
|
||||
Just altSize'
|
||||
-> fmap getFirst . execWriterT . cachedARC' ah (ref, (s, altSize')) $ \x -> x <$ case x of
|
||||
Nothing -> tellM $ First <$> getChunkDB
|
||||
Just (v, _) -> tell . First . Just $ ByteString.take l v
|
||||
Nothing -> getChunkDB
|
||||
for chunk' $ \chunk -> do
|
||||
let w = length chunk
|
||||
$logDebugS "fileChunkARC" "ARC miss"
|
||||
return (chunk, w)
|
||||
Just x@(_, w) -> do
|
||||
$logDebugS "fileChunkARC" "ARC hit"
|
||||
liftIO $ Just x <$ observeSourcedChunk StorageARC w
|
||||
|
||||
in liftIO $ observeSourcedChunk storage w
|
||||
|
||||
|
||||
sourceFileDB :: forall m.
|
||||
@ -124,7 +99,7 @@ sourceFileChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlRe
|
||||
return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize)
|
||||
getChunkMinio = fmap (, StorageMinio) . catchIfMaybeT (is _SourceFilesContentUnavailable) . runConduit $ sourceMinio (Left chunkHash) (Just $ ByteRangeFromTo (fromIntegral $ pred start) (fromIntegral . pred $ pred start + dbChunksize)) .| C.fold
|
||||
in getChunkDB' <|> getChunkMinio
|
||||
chunk <- fileChunkARC Nothing (chunkHash, (start, dbChunksize)) getChunkDB
|
||||
chunk <- fileChunk (chunkHash, (start, dbChunksize)) getChunkDB
|
||||
case chunk of
|
||||
Just c | olength c <= 0 -> return Nothing
|
||||
Just c -> do
|
||||
@ -256,7 +231,7 @@ respondFileConditional representationLastModified cType FileReference{..} = do
|
||||
let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectOne . E.from $ \fileContentChunk -> do
|
||||
E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash
|
||||
return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize)
|
||||
chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB
|
||||
chunk <- fileChunk (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB
|
||||
case chunk of
|
||||
Nothing -> throwM SourceFilesContentUnavailable
|
||||
Just c -> do
|
||||
|
||||
@ -11,7 +11,6 @@ module Handler.Utils.Memcached
|
||||
, memcachedHere, memcachedByHere
|
||||
, memcachedSet, memcachedGet
|
||||
, memcachedInvalidate, memcachedByInvalidate, memcachedFlushAll
|
||||
, manageMemcachedLocalInvalidations
|
||||
, memcachedByGet, memcachedBySet
|
||||
, memcachedTimeout, memcachedTimeoutBy
|
||||
, memcachedTimeoutHere, memcachedTimeoutByHere
|
||||
@ -45,11 +44,9 @@ import qualified Data.Set as Set
|
||||
|
||||
import qualified Data.ByteArray as BA
|
||||
|
||||
import qualified Data.ByteString.Base64 as Base64
|
||||
|
||||
import Language.Haskell.TH hiding (Type)
|
||||
|
||||
import Data.Typeable (typeRep, typeRepFingerprint)
|
||||
import Data.Typeable (typeRep)
|
||||
import Type.Reflection (typeOf, TypeRep)
|
||||
import qualified Type.Reflection as Refl (typeRep)
|
||||
import Data.Type.Equality (TestEquality(..))
|
||||
@ -72,10 +69,6 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
||||
|
||||
import GHC.Fingerprint
|
||||
|
||||
import Utils.Postgresql
|
||||
|
||||
import UnliftIO.Concurrent (threadDelay)
|
||||
|
||||
|
||||
type Expiry = Either UTCTime DiffTime
|
||||
|
||||
@ -169,68 +162,49 @@ memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do
|
||||
|
||||
memcachedByGet :: forall a k m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> k -> m (Maybe a)
|
||||
memcachedByGet (Binary.encode -> k) = runMaybeT $ arc <|> memcache
|
||||
where
|
||||
arc = do
|
||||
AppMemcachedLocal{..} <- MaybeT $ getsYesod appMemcachedLocal
|
||||
res <- hoistMaybe . preview (_1 . _NFDynamic) <=< hoistMaybe <=< cachedARC' memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) $ \mPrev -> do
|
||||
prev@((_, prevExpiry), _) <- hoistMaybe mPrev
|
||||
$logDebugS "memcached" "Cache hit (local ARC)"
|
||||
lift . runMaybeT $ do -- To delete from ARC upon expiry
|
||||
for_ prevExpiry $ \expiry -> do
|
||||
memcachedByGet (Binary.encode -> k) = runMaybeT $ do
|
||||
AppMemcached{..} <- MaybeT $ getsYesod appMemcached
|
||||
let cKey = toMemcachedKey memcachedKey (Proxy @a) k
|
||||
encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey memcachedConn
|
||||
-- $logDebugS "memcached" "Cache hit"
|
||||
|
||||
let withExp doExp = do
|
||||
MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp
|
||||
$logDebugS "memcached" "Decode valid"
|
||||
for_ mExpiry $ \expiry -> do
|
||||
now <- liftIO getPOSIXTime
|
||||
guard $ expiry > now
|
||||
return prev
|
||||
$logDebugS "memcached" "All valid (local ARC)"
|
||||
return res
|
||||
memcache = do
|
||||
AppMemcached{..} <- MaybeT $ getsYesod appMemcached
|
||||
localARC <- getsYesod appMemcachedLocal
|
||||
let cKey = toMemcachedKey memcachedKey (Proxy @a) k
|
||||
guard $ expiry > now + clockLeniency
|
||||
$logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
|
||||
let aad = memcachedAAD cKey mExpiry
|
||||
decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad
|
||||
|
||||
encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey memcachedConn
|
||||
$logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration"
|
||||
|
||||
$logDebugS "memcached" "Cache hit"
|
||||
{-
|
||||
let withCache = fmap (view _1) . ($ Nothing)
|
||||
res <- hoistMaybe . preview (_1 . _NFDynamic) <=< withCache $ \case
|
||||
Nothing -> fmap ((, length decrypted) . (, mExpiry) . review (_NFDynamic @a)) . hoistMaybe $ runGetMaybe Binary.get decrypted
|
||||
Just p -> return p
|
||||
-}
|
||||
hoistMaybe $ runGetMaybe Binary.get decrypted
|
||||
|
||||
let withExp doExp = do
|
||||
MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp
|
||||
$logDebugS "memcached" "Decode valid"
|
||||
for_ mExpiry $ \expiry -> do
|
||||
now <- liftIO getPOSIXTime
|
||||
guard $ expiry > now + clockLeniency
|
||||
$logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
|
||||
let aad = memcachedAAD cKey mExpiry
|
||||
decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad
|
||||
withExp True <|> withExp False
|
||||
where
|
||||
runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of
|
||||
Right (bs', _, x) | null bs' -> Just x
|
||||
_other -> Nothing
|
||||
|
||||
$logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration"
|
||||
|
||||
let withCache = case localARC of
|
||||
Just AppMemcachedLocal{..} -> cachedARC memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k)
|
||||
Nothing -> fmap (view _1) . ($ Nothing)
|
||||
res <- hoistMaybe . preview (_1 . _NFDynamic) <=< withCache $ \case
|
||||
Nothing -> fmap ((, length decrypted) . (, mExpiry) . review (_NFDynamic @a)) . hoistMaybe $ runGetMaybe Binary.get decrypted
|
||||
Just p -> return p
|
||||
|
||||
$logDebugS "memcached" "All valid"
|
||||
|
||||
return res
|
||||
|
||||
withExp True <|> withExp False
|
||||
where
|
||||
runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of
|
||||
Right (bs', _, x) | null bs' -> Just x
|
||||
_other -> Nothing
|
||||
clockLeniency :: NominalDiffTime
|
||||
clockLeniency = 2
|
||||
clockLeniency :: NominalDiffTime
|
||||
clockLeniency = 2
|
||||
|
||||
memcachedBySet :: forall a k m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> Maybe Expiry -> k -> a -> m ()
|
||||
@ -239,7 +213,7 @@ memcachedBySet = ((void .) .) . memcachedBySet'
|
||||
memcachedBySet' :: forall a k m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> Maybe Expiry -> k -> a -> m (Maybe ByteString)
|
||||
@ -252,7 +226,7 @@ memcachedBySet' mExp (Binary.encode -> k) v = do
|
||||
Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime
|
||||
|
||||
mConn <- getsYesod appMemcached
|
||||
bsKey <- for mConn $ \AppMemcached{..} -> do
|
||||
for mConn $ \AppMemcached{..} -> do
|
||||
mNonce <- liftIO AEAD.newNonce
|
||||
let cKey = toMemcachedKey memcachedKey (Proxy @a) k
|
||||
aad = memcachedAAD cKey mExpiry
|
||||
@ -261,36 +235,17 @@ memcachedBySet' mExp (Binary.encode -> k) v = do
|
||||
$logDebugS "memcached" $ "Cache store: " <> tshow mExpiry
|
||||
return cKey
|
||||
|
||||
mLocal <- getsYesod appMemcachedLocal
|
||||
for_ mLocal $ \AppMemcachedLocal{..} -> do
|
||||
void . cachedARC memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) . const $ return ((_NFDynamic # v, mExpiry), length decrypted)
|
||||
$logDebugS "memcached" $ "Cache store: " <> tshow mExpiry <> " (local ARC)"
|
||||
-- DEBUG
|
||||
let inv = Base64.encode . toStrict $ Binary.encode MemcachedLocalInvalidateMsg{..}
|
||||
where mLocalInvalidateType = typeRepFingerprint . typeRep $ Proxy @a
|
||||
mLocalInvalidateKey = k
|
||||
$logDebugS "memcached" $ "To invalidate remotely: " <> tshow inv
|
||||
return bsKey
|
||||
|
||||
memcachedByInvalidate :: forall a k m p.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, Typeable a
|
||||
, Binary k
|
||||
)
|
||||
=> k -> p a -> m ()
|
||||
memcachedByInvalidate (Binary.encode -> k) _ = arc >> memcache
|
||||
where
|
||||
memcache = maybeT_ $ do
|
||||
AppMemcached{..} <- MaybeT $ getsYesod appMemcached
|
||||
let cKey = toMemcachedKey memcachedKey (Proxy @a) k
|
||||
hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey memcachedConn
|
||||
$logDebugS "memcached" "Cache invalidation"
|
||||
arc = maybeT_ $ do
|
||||
AppMemcachedLocal{..} <- MaybeT $ getsYesod appMemcachedLocal
|
||||
let arcKey = (typeRepFingerprint . typeRep $ Proxy @a, k)
|
||||
atomically $ modifyTVar' memcachedLocalInvalidationQueue (:> arcKey)
|
||||
void . cachedARC' memcachedLocalARC arcKey . const $ return Nothing
|
||||
$logDebugS "memcached" "Cache invalidation (local ARC)"
|
||||
memcachedByInvalidate (Binary.encode -> k) _ = maybeT_ $ do
|
||||
AppMemcached{..} <- MaybeT $ getsYesod appMemcached
|
||||
let cKey = toMemcachedKey memcachedKey (Proxy @a) k
|
||||
hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey memcachedConn
|
||||
$logDebugS "memcached" "Cache invalidation"
|
||||
|
||||
data MemcachedLocalInvalidateMsg = MemcachedLocalInvalidateMsg
|
||||
{ mLocalInvalidateType :: Fingerprint
|
||||
@ -308,6 +263,7 @@ instance Binary MemcachedLocalInvalidateMsg where
|
||||
Binary.putWord64le w2
|
||||
Binary.putLazyByteString mLocalInvalidateKey
|
||||
|
||||
{-
|
||||
manageMemcachedLocalInvalidations :: ( MonadUnliftIO m
|
||||
, MonadLogger m
|
||||
)
|
||||
@ -330,7 +286,7 @@ manageMemcachedLocalInvalidations localARC iQueue = PostgresqlChannelManager
|
||||
let (mLocalInvalidateType, mLocalInvalidateKey) = i
|
||||
return . Base64.encode . toStrict $ Binary.encode MemcachedLocalInvalidateMsg{..}
|
||||
}
|
||||
|
||||
-}
|
||||
|
||||
newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a }
|
||||
deriving newtype (Eq, Ord, Show, Binary)
|
||||
@ -338,14 +294,14 @@ instance NFData a => NFData (MemcachedUnkeyed a) where
|
||||
rnf = rnf . unMemcachedUnkeyed
|
||||
|
||||
memcachedGet :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
)
|
||||
=> m (Maybe a)
|
||||
memcachedGet = fmap unMemcachedUnkeyed <$> memcachedByGet ()
|
||||
|
||||
memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
)
|
||||
=> Maybe Expiry -> a -> m ()
|
||||
memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed
|
||||
@ -366,7 +322,7 @@ memcachedWith (doGet, doSet) act = maybeM (act >>= doSet) pure doGet
|
||||
|
||||
memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
)
|
||||
=> Maybe Expiry -> m a -> m a
|
||||
memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x)
|
||||
@ -374,7 +330,7 @@ memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x)
|
||||
memcachedBy :: forall a m k.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> Maybe Expiry -> k -> m a -> m a
|
||||
@ -394,7 +350,7 @@ newtype MemcachedKeyClassStore = MemcachedKeyClassStore{ unMemcachedKeyClassStor
|
||||
memcachedByClass :: forall a m k.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> MemcachedKeyClass -> Maybe Expiry -> k -> m a -> m a
|
||||
@ -500,7 +456,7 @@ memcachedLimitedWith (doGet, doSet) liftAct (hashableDynamic -> lK) burst rate t
|
||||
memcachedLimited :: forall a m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
)
|
||||
=> Word64 -- ^ burst-size (tokens)
|
||||
-> Word64 -- ^ avg. inverse rate (usec/token)
|
||||
@ -513,7 +469,7 @@ memcachedLimited burst rate tokens mExp = memcachedLimitedWith (memcachedGet, me
|
||||
memcachedLimitedKey :: forall a k' m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Typeable k', Hashable k', Eq k'
|
||||
)
|
||||
=> k'
|
||||
@ -528,7 +484,7 @@ memcachedLimitedKey lK burst rate tokens mExp = memcachedLimitedWith (memcachedG
|
||||
memcachedLimitedBy :: forall a k m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> Word64 -- ^ burst-size (tokens)
|
||||
@ -543,7 +499,7 @@ memcachedLimitedBy burst rate tokens mExp k = memcachedLimitedWith (memcachedByG
|
||||
memcachedLimitedKeyBy :: forall a k' k m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Typeable k', Hashable k', Eq k'
|
||||
, Binary k
|
||||
)
|
||||
@ -581,7 +537,7 @@ memcachedLimitedKeyByHere = do
|
||||
memcacheAuth :: forall m k a.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> k
|
||||
@ -602,7 +558,7 @@ memcacheAuth k mx = cachedByBinary k $ do
|
||||
memcacheAuth' :: forall a m k.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> Expiry
|
||||
@ -614,7 +570,7 @@ memcacheAuth' exp k = memcacheAuth k . (<* tell (Just $ Min exp)) . lift
|
||||
memcacheAuthMax :: forall m k a.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> Expiry
|
||||
@ -728,7 +684,7 @@ memcachedTimeout :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, MonadUnliftIO m
|
||||
, Typeable k'', Hashable k'', Eq k''
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
)
|
||||
=> Maybe Expiry -> DiffTime -> k'' -> m a -> m (Maybe a)
|
||||
memcachedTimeout mExp = memcachedTimeoutWith (memcachedGet, memcachedSet mExp)
|
||||
@ -737,7 +693,7 @@ memcachedTimeoutBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, MonadUnliftIO m
|
||||
, Typeable k'', Hashable k'', Eq k''
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> Maybe Expiry -> DiffTime -> k'' -> k -> m a -> m (Maybe a)
|
||||
@ -758,7 +714,7 @@ memcachedLimitedTimeout :: forall a k'' m.
|
||||
, MonadThrow m
|
||||
, MonadUnliftIO m
|
||||
, Typeable k'', Hashable k'', Eq k''
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
)
|
||||
=> Word64 -- ^ burst-size (tokens)
|
||||
-> Word64 -- ^ avg. inverse rate (usec/token)
|
||||
@ -775,7 +731,7 @@ memcachedLimitedKeyTimeout :: forall a k' k'' m.
|
||||
, MonadThrow m
|
||||
, MonadUnliftIO m
|
||||
, Typeable k'', Hashable k'', Eq k''
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Typeable k', Hashable k', Eq k'
|
||||
)
|
||||
=> k'
|
||||
@ -794,7 +750,7 @@ memcachedLimitedTimeoutBy :: forall a k'' k m.
|
||||
, MonadThrow m
|
||||
, MonadUnliftIO m
|
||||
, Typeable k'', Hashable k'', Eq k''
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Binary k
|
||||
)
|
||||
=> Word64 -- ^ burst-size (tokens)
|
||||
@ -813,7 +769,7 @@ memcachedLimitedKeyTimeoutBy :: forall a k' k'' k m.
|
||||
, MonadThrow m
|
||||
, MonadUnliftIO m
|
||||
, Typeable k'', Hashable k'', Eq k''
|
||||
, Typeable a, Binary a, NFData a
|
||||
, Typeable a, Binary a
|
||||
, Typeable k', Hashable k', Eq k'
|
||||
, Binary k
|
||||
)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>,-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -207,7 +207,6 @@ data AppSettings = AppSettings
|
||||
|
||||
, appMemcachedConf :: Maybe MemcachedConf
|
||||
, appMemcacheAuth :: Bool
|
||||
, appMemcachedLocalConf :: Maybe (ARCConf Int)
|
||||
|
||||
, appUploadCacheConf :: Maybe Minio.ConnectInfo
|
||||
, appUploadCacheBucket, appUploadTmpBucket :: Minio.Bucket
|
||||
@ -688,7 +687,6 @@ instance FromJSON AppSettings where
|
||||
|
||||
appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached"
|
||||
appMemcacheAuth <- o .:? "memcache-auth" .!= False
|
||||
appMemcachedLocalConf <- assertM isValidARCConf <$> o .:? "memcached-local"
|
||||
|
||||
appMailFrom <- o .: "mail-from"
|
||||
appMailEnvelopeFrom <- o .:? "mail-envelope-from" .!= addressEmail appMailFrom
|
||||
|
||||
@ -44,7 +44,6 @@ import Utils.I18n as Utils
|
||||
import Utils.NTop as Utils
|
||||
import Utils.HttpConditional as Utils
|
||||
import Utils.Persist as Utils
|
||||
import Utils.ARC as Utils
|
||||
import Utils.LRU as Utils
|
||||
import Utils.Set as Utils
|
||||
|
||||
|
||||
344
src/Utils/ARC.hs
344
src/Utils/ARC.hs
@ -1,344 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module Utils.ARC
|
||||
( ARCTick
|
||||
, ARC, initARC
|
||||
, arcAlterF, lookupARC, insertARC
|
||||
, ARCHandle, initARCHandle, cachedARC, cachedARC'
|
||||
, lookupARCHandle
|
||||
, readARCHandle
|
||||
, arcRecentSize, arcFrequentSize, arcGhostRecentSize, arcGhostFrequentSize
|
||||
, getARCRecentWeight, getARCFrequentWeight
|
||||
, describeARC
|
||||
, NFDynamic(..), _NFDynamic, DynARC, DynARCHandle
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.HashPSQ (HashPSQ)
|
||||
import qualified Data.HashPSQ as HashPSQ
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import Type.Reflection
|
||||
import Text.Show (showString, shows)
|
||||
|
||||
import Data.Hashable (Hashed, hashed)
|
||||
|
||||
-- https://web.archive.org/web/20210115184012/https://dbs.uni-leipzig.de/file/ARC.pdf
|
||||
-- https://jaspervdj.be/posts/2015-02-24-lru-cache.html
|
||||
|
||||
|
||||
data NFDynamic where
|
||||
NFDynamic :: forall a. NFData a => TypeRep a -> a -> NFDynamic
|
||||
|
||||
_NFDynamic :: forall a. (Typeable a, NFData a) => Prism' NFDynamic a
|
||||
_NFDynamic = prism' toNFDyn fromNFDynamic
|
||||
where
|
||||
toNFDyn v = NFDynamic typeRep v
|
||||
fromNFDynamic (NFDynamic t v)
|
||||
| Just HRefl <- t `eqTypeRep` rep = Just v
|
||||
| otherwise = Nothing
|
||||
where rep = typeRep :: TypeRep a
|
||||
|
||||
instance NFData NFDynamic where
|
||||
rnf (NFDynamic t v) = rnfTypeRep t `seq` rnf v
|
||||
|
||||
instance Show NFDynamic where
|
||||
showsPrec _ (NFDynamic t _) = showString "<<" . shows t . showString ">>"
|
||||
|
||||
|
||||
newtype ARCTick = ARCTick { _getARCTick :: Word64 }
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving newtype (NFData)
|
||||
|
||||
makeLenses ''ARCTick
|
||||
|
||||
data ARC k w v = ARC
|
||||
{ arcRecent, arcFrequent :: !(HashPSQ (Hashed k) ARCTick (v, w))
|
||||
, arcGhostRecent, arcGhostFrequent :: !(HashPSQ (Hashed k) ARCTick ())
|
||||
, arcRecentWeight, arcFrequentWeight :: !w
|
||||
, arcTargetRecent, arcMaximumWeight :: !w
|
||||
, arcMaximumGhost :: !Int
|
||||
}
|
||||
|
||||
type DynARC k w = ARC (SomeTypeRep, k) w NFDynamic
|
||||
|
||||
instance (NFData k, NFData w, NFData v) => NFData (ARC k w v) where
|
||||
rnf ARC{..} = rnf arcRecent
|
||||
`seq` rnf arcFrequent
|
||||
`seq` rnf arcGhostRecent
|
||||
`seq` rnf arcGhostFrequent
|
||||
`seq` rnf arcRecentWeight
|
||||
`seq` rnf arcFrequentWeight
|
||||
`seq` rnf arcTargetRecent
|
||||
`seq` rnf arcMaximumWeight
|
||||
`seq` rnf arcMaximumGhost
|
||||
|
||||
describeARC :: Show w
|
||||
=> ARC k w v
|
||||
-> String
|
||||
describeARC ARC{..} = intercalate ", "
|
||||
[ "arcRecent: " <> show (HashPSQ.size arcRecent)
|
||||
, "arcFrequent: " <> show (HashPSQ.size arcFrequent)
|
||||
, "arcGhostRecent: " <> show (HashPSQ.size arcGhostRecent)
|
||||
, "arcGhostFrequent: " <> show (HashPSQ.size arcGhostFrequent)
|
||||
, "arcRecentWeight: " <> show arcRecentWeight
|
||||
, "arcFrequentWeight: " <> show arcFrequentWeight
|
||||
, "arcTargetRecent: " <> show arcTargetRecent
|
||||
, "arcMaximumWeight: " <> show arcMaximumWeight
|
||||
, "arcMaximumGhost: " <> show arcMaximumGhost
|
||||
]
|
||||
|
||||
arcRecentSize, arcFrequentSize, arcGhostRecentSize, arcGhostFrequentSize :: ARC k w v -> Int
|
||||
arcRecentSize = HashPSQ.size . arcRecent
|
||||
arcFrequentSize = HashPSQ.size . arcFrequent
|
||||
arcGhostRecentSize = HashPSQ.size . arcGhostRecent
|
||||
arcGhostFrequentSize = HashPSQ.size . arcGhostFrequent
|
||||
|
||||
getARCRecentWeight, getARCFrequentWeight :: ARC k w v -> w
|
||||
getARCRecentWeight = arcRecentWeight
|
||||
getARCFrequentWeight = arcFrequentWeight
|
||||
|
||||
initialARCTick :: ARCTick
|
||||
initialARCTick = ARCTick 0
|
||||
|
||||
initARC :: forall k w v.
|
||||
Integral w
|
||||
=> Int -- ^ @arcMaximumGhost@
|
||||
-> w -- ^ @arcMaximumWeight@
|
||||
-> (ARC k w v, ARCTick)
|
||||
initARC arcMaximumGhost arcMaximumWeight
|
||||
| arcMaximumWeight < 0 = error "initARC given negative maximum weight"
|
||||
| arcMaximumGhost < 0 = error "initARC given negative maximum ghost size"
|
||||
| otherwise = (, initialARCTick) ARC
|
||||
{ arcRecent = HashPSQ.empty
|
||||
, arcFrequent = HashPSQ.empty
|
||||
, arcGhostRecent = HashPSQ.empty
|
||||
, arcGhostFrequent = HashPSQ.empty
|
||||
, arcRecentWeight = 0
|
||||
, arcFrequentWeight = 0
|
||||
, arcMaximumWeight
|
||||
, arcTargetRecent = 0
|
||||
, arcMaximumGhost
|
||||
}
|
||||
|
||||
|
||||
infixl 6 |-
|
||||
(|-) :: (Num a, Ord a) => a -> a -> a
|
||||
(|-) m s
|
||||
| s >= m = 0
|
||||
| otherwise = m - s
|
||||
|
||||
|
||||
arcAlterF :: forall f k w v.
|
||||
( Ord k, Hashable k
|
||||
, Functor f
|
||||
, Integral w
|
||||
, NFData k, NFData w, NFData v
|
||||
)
|
||||
=> k
|
||||
-> (Maybe (v, w) -> f (Maybe (v, w)))
|
||||
-> ARC k w v
|
||||
-> ARCTick -> f (ARC k w v, ARCTick)
|
||||
-- | Unchecked precondition: item weights are always less than `arcMaximumWeight`
|
||||
arcAlterF !(force -> unhashedK@(hashed -> k)) f oldARC@ARC{..} now
|
||||
| later <= initialARCTick = uncurry (arcAlterF unhashedK f) $ initARC arcMaximumGhost arcMaximumWeight
|
||||
| otherwise = (, later) <$> if
|
||||
| Just (_p, x@(_, w), arcFrequent') <- HashPSQ.deleteView k arcFrequent
|
||||
-> f (Just x) <&> \case
|
||||
Nothing -> oldARC
|
||||
{ arcFrequent = arcFrequent'
|
||||
, arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent
|
||||
, arcFrequentWeight = arcFrequentWeight - w
|
||||
}
|
||||
Just !(force -> x'@(_, w'))
|
||||
-> let (arcFrequent'', arcFrequentWeight'', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent' (arcFrequentWeight - w) arcGhostFrequent
|
||||
in oldARC
|
||||
{ arcFrequent = HashPSQ.insert k now x' arcFrequent''
|
||||
, arcFrequentWeight = arcFrequentWeight'' + w'
|
||||
, arcGhostFrequent = arcGhostFrequent'
|
||||
}
|
||||
| Just (_p, x@(_, w), arcRecent') <- HashPSQ.deleteView k arcRecent
|
||||
-> f (Just x) <&> \case
|
||||
Nothing -> oldARC
|
||||
{ arcRecent = arcRecent'
|
||||
, arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent
|
||||
, arcRecentWeight = arcRecentWeight - w
|
||||
}
|
||||
Just !(force -> x'@(_, w'))
|
||||
-> let (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent arcFrequentWeight arcGhostFrequent
|
||||
in oldARC
|
||||
{ arcRecent = arcRecent'
|
||||
, arcRecentWeight = arcRecentWeight - w
|
||||
, arcFrequent = HashPSQ.insert k now x' arcFrequent'
|
||||
, arcFrequentWeight = arcFrequentWeight' + w'
|
||||
, arcGhostFrequent = arcGhostFrequent'
|
||||
}
|
||||
| Just (_p, (), arcGhostRecent') <- HashPSQ.deleteView k arcGhostRecent
|
||||
-> f Nothing <&> \case
|
||||
Nothing -> oldARC
|
||||
{ arcGhostRecent = HashPSQ.insert k now () arcGhostRecent'
|
||||
}
|
||||
Just !(force -> x@(_, w))
|
||||
-> let arcTargetRecent' = min arcMaximumWeight $ arcTargetRecent + max avgWeight (round $ toRational (HashPSQ.size arcGhostFrequent) / toRational (HashPSQ.size arcGhostRecent) * toRational avgWeight)
|
||||
(arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent
|
||||
(arcRecent', arcRecentWeight', arcGhostRecent'') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent'
|
||||
in oldARC
|
||||
{ arcRecent = arcRecent'
|
||||
, arcFrequent = HashPSQ.insert k now x arcFrequent'
|
||||
, arcGhostRecent = arcGhostRecent''
|
||||
, arcGhostFrequent = arcGhostFrequent'
|
||||
, arcRecentWeight = arcRecentWeight'
|
||||
, arcFrequentWeight = arcFrequentWeight' + w
|
||||
, arcTargetRecent = arcTargetRecent'
|
||||
}
|
||||
| Just (_p, (), arcGhostFrequent') <- HashPSQ.deleteView k arcGhostFrequent
|
||||
-> f Nothing <&> \case
|
||||
Nothing -> oldARC
|
||||
{ arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent'
|
||||
}
|
||||
Just !(force -> x@(_, w))
|
||||
-> let arcTargetRecent' = arcTargetRecent |- max avgWeight (round $ toRational (HashPSQ.size arcGhostRecent) / toRational (HashPSQ.size arcGhostFrequent) * toRational avgWeight)
|
||||
(arcFrequent', arcFrequentWeight', arcGhostFrequent'') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent'
|
||||
(arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent
|
||||
in oldARC
|
||||
{ arcRecent = arcRecent'
|
||||
, arcFrequent = HashPSQ.insert k now x arcFrequent'
|
||||
, arcGhostRecent = arcGhostRecent'
|
||||
, arcGhostFrequent = arcGhostFrequent''
|
||||
, arcRecentWeight = arcRecentWeight'
|
||||
, arcFrequentWeight = arcFrequentWeight' + w
|
||||
, arcTargetRecent = arcTargetRecent'
|
||||
}
|
||||
| otherwise -> f Nothing <&> \case
|
||||
Nothing -> oldARC
|
||||
{ arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent
|
||||
}
|
||||
Just !(force -> x@(_, w))
|
||||
-> let (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent (arcMaximumWeight |- arcFrequentWeight) |- w) arcRecent arcRecentWeight arcGhostRecent
|
||||
in oldARC
|
||||
{ arcRecent = HashPSQ.insert k now x arcRecent'
|
||||
, arcRecentWeight = arcRecentWeight' + w
|
||||
, arcGhostRecent = arcGhostRecent'
|
||||
}
|
||||
where
|
||||
avgWeight = round $ toRational (arcRecentWeight + arcFrequentWeight) / toRational (HashPSQ.size arcFrequent + HashPSQ.size arcRecent)
|
||||
|
||||
later :: ARCTick
|
||||
later = over getARCTick succ now
|
||||
|
||||
evictToSize :: w -> HashPSQ (Hashed k) ARCTick (v, w) -> w -> HashPSQ (Hashed k) ARCTick () -> (HashPSQ (Hashed k) ARCTick (v, w), w, HashPSQ (Hashed k) ARCTick ())
|
||||
evictToSize tSize c cSize ghostC
|
||||
| cSize <= tSize = (c, cSize, ghostC)
|
||||
| Just (k', p', (_, w'), c') <- HashPSQ.minView c = evictToSize tSize c' (cSize - w') . evictGhostToCount $ HashPSQ.insert k' p' () ghostC
|
||||
| otherwise = error "evictToSize: cannot reach required size through eviction"
|
||||
|
||||
evictGhostToCount :: HashPSQ (Hashed k) ARCTick () -> HashPSQ (Hashed k) ARCTick ()
|
||||
evictGhostToCount c
|
||||
| HashPSQ.size c <= arcMaximumGhost = c
|
||||
| Just (_, _, _, c') <- HashPSQ.minView c = evictGhostToCount c'
|
||||
| otherwise = error "evictGhostToCount: cannot reach required count through eviction"
|
||||
|
||||
lookupARC :: forall k w v.
|
||||
( Ord k, Hashable k
|
||||
, Integral w
|
||||
, NFData k, NFData w, NFData v
|
||||
)
|
||||
=> k
|
||||
-> (ARC k w v, ARCTick)
|
||||
-> Maybe (v, w)
|
||||
lookupARC k = getConst . uncurry (arcAlterF k Const)
|
||||
|
||||
insertARC :: forall k w v.
|
||||
( Ord k, Hashable k
|
||||
, Integral w
|
||||
, NFData k, NFData w, NFData v
|
||||
)
|
||||
=> k
|
||||
-> Maybe (v, w)
|
||||
-> ARC k w v
|
||||
-> ARCTick -> (ARC k w v, ARCTick)
|
||||
insertARC k newVal = (runIdentity .) . arcAlterF k (const $ pure newVal)
|
||||
|
||||
|
||||
newtype ARCHandle k w v = ARCHandle { _getARCHandle :: IORef (ARC k w v, ARCTick) }
|
||||
deriving (Eq)
|
||||
|
||||
type DynARCHandle k w = ARCHandle (SomeTypeRep, k) w NFDynamic
|
||||
|
||||
initARCHandle :: forall k w v m.
|
||||
( MonadIO m
|
||||
, Integral w
|
||||
)
|
||||
=> Int -- ^ @arcMaximumGhost@
|
||||
-> w -- ^ @arcMaximumWeight@
|
||||
-> m (ARCHandle k w v)
|
||||
initARCHandle maxGhost maxWeight = fmap ARCHandle . newIORef $ initARC maxGhost maxWeight
|
||||
|
||||
cachedARC' :: forall k w v m.
|
||||
( MonadIO m
|
||||
, Ord k, Hashable k
|
||||
, Integral w
|
||||
, NFData k, NFData w, NFData v
|
||||
)
|
||||
=> ARCHandle k w v
|
||||
-> k
|
||||
-> (Maybe (v, w) -> m (Maybe (v, w)))
|
||||
-> m (Maybe v)
|
||||
cachedARC' (ARCHandle arcVar) k f = do
|
||||
oldVal <- lookupARC k <$> readIORef arcVar
|
||||
newVal <- f oldVal
|
||||
atomicModifyIORef' arcVar $ (, ()) . uncurry (insertARC k newVal)
|
||||
-- Using `modifyIORef'` instead of `atomicModifyIORef'` might very
|
||||
-- well drop newer values computed during the update.
|
||||
--
|
||||
-- This was deemed unacceptable due to the risk of cache
|
||||
-- invalidations being silently dropped
|
||||
--
|
||||
-- Another alternative would be to use "optimistic locking",
|
||||
-- i.e. read the current value of `arcVar`, compute an updated
|
||||
-- version, and write it back atomically iff the `ARCTick` hasn't
|
||||
-- changed.
|
||||
--
|
||||
-- This was not implemented in the hopes that atomicModifyIORef'
|
||||
-- already offers sufficient performance.
|
||||
--
|
||||
-- If optimistic locking is implemented there is a risk of
|
||||
-- performance issues due to the overhead and contention likely
|
||||
-- associated with the atomic transaction required for the "compare
|
||||
-- and swap"
|
||||
return $ view _1 <$> newVal
|
||||
|
||||
cachedARC :: forall k w v m.
|
||||
( MonadIO m
|
||||
, Ord k, Hashable k
|
||||
, Integral w
|
||||
, NFData k, NFData w, NFData v
|
||||
)
|
||||
=> ARCHandle k w v
|
||||
-> k
|
||||
-> (Maybe (v, w) -> m (v, w))
|
||||
-> m v
|
||||
cachedARC h k f = fromMaybe (error "cachedARC: cachedARC' returned Nothing") <$> cachedARC' h k (fmap Just . f)
|
||||
|
||||
lookupARCHandle :: forall k w v m.
|
||||
( MonadIO m
|
||||
, Ord k, Hashable k
|
||||
, Integral w
|
||||
, NFData k, NFData w, NFData v
|
||||
)
|
||||
=> ARCHandle k w v
|
||||
-> k
|
||||
-> m (Maybe (v, w))
|
||||
lookupARCHandle (ARCHandle arcVar) k = lookupARC k <$> readIORef arcVar
|
||||
|
||||
|
||||
readARCHandle :: MonadIO m
|
||||
=> ARCHandle k w v
|
||||
-> m (ARC k w v, ARCTick)
|
||||
readARCHandle (ARCHandle arcVar) = readIORef arcVar
|
||||
@ -66,11 +66,11 @@ initLRU :: forall k t w v.
|
||||
-> (LRU k t w v, LRUTick)
|
||||
initLRU lruMaximumWeight
|
||||
| lruMaximumWeight < 0 = error "initLRU given negative maximum weight"
|
||||
| otherwise = (, initialLRUTick) LRU
|
||||
{ lruStore = OrdPSQ.empty
|
||||
, lruWeight = 0
|
||||
, lruMaximumWeight
|
||||
}
|
||||
| otherwise = (lru, initialLRUTick)
|
||||
where lru = LRU { lruStore = OrdPSQ.empty
|
||||
, lruWeight = 0
|
||||
, lruMaximumWeight
|
||||
}
|
||||
|
||||
insertLRU :: forall k t w v.
|
||||
( Ord k, Ord t
|
||||
@ -84,18 +84,18 @@ insertLRU :: forall k t w v.
|
||||
insertLRU k t newVal oldLRU@LRU{..} now
|
||||
| later <= initialLRUTick = uncurry (insertLRU k t newVal) $ initLRU lruMaximumWeight
|
||||
| Just (_, w) <- newVal, w > lruMaximumWeight = (oldLRU, now)
|
||||
| Just (_, w) <- newVal = (, later) $
|
||||
| Just (_, w) <- newVal = (, later) $
|
||||
let (lruStore', lruWeight') = evictToSize (lruMaximumWeight - w) lruStore lruWeight
|
||||
(fromMaybe 0 . preview (_Just . _2 . _2) -> oldWeight, lruStore'')
|
||||
= OrdPSQ.alter (, ((t, now), ) <$> newVal) k lruStore'
|
||||
in oldLRU
|
||||
{ lruStore = lruStore''
|
||||
, lruWeight = lruWeight' - oldWeight + w
|
||||
}
|
||||
| Just (_, (_, w), lruStore') <- OrdPSQ.deleteView k lruStore = (, now) oldLRU
|
||||
{ lruStore = lruStore'
|
||||
, lruWeight = lruWeight - w
|
||||
}
|
||||
in oldLRU { lruStore = lruStore''
|
||||
, lruWeight = lruWeight' - oldWeight + w
|
||||
}
|
||||
| Just (_, (_, w), lruStore') <- OrdPSQ.deleteView k lruStore =
|
||||
let lru = oldLRU { lruStore = lruStore'
|
||||
, lruWeight = lruWeight - w
|
||||
}
|
||||
in (lru, now)
|
||||
| otherwise = (oldLRU, now)
|
||||
where
|
||||
later :: LRUTick
|
||||
@ -127,9 +127,9 @@ touchLRU k t oldLRU@LRU{..} now
|
||||
, later <= initialLRUTick = (, Just v) . uncurry (insertLRU k t $ Just v) $ initLRU lruMaximumWeight
|
||||
| (Just (_, v), lruStore') <- altered = ((oldLRU{ lruStore = lruStore' }, later), Just v)
|
||||
| otherwise = ((oldLRU, now), Nothing)
|
||||
where
|
||||
where
|
||||
altered = OrdPSQ.alter (\oldVal -> (oldVal, over _1 (max (t, later)) <$> oldVal)) k lruStore
|
||||
|
||||
|
||||
later :: LRUTick
|
||||
later = over getLRUTick succ now
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -19,8 +19,6 @@ module Utils.Metrics
|
||||
, observeDeletedUnreferencedFiles, observeDeletedUnreferencedChunks, observeInjectedFiles, observeRechunkedFiles
|
||||
, registerJobWorkerQueueDepth
|
||||
, observeMissingFiles
|
||||
, ARCMetrics, ARCLabel(..)
|
||||
, arcMetrics
|
||||
, LRUMetrics, LRULabel(..)
|
||||
, lruMetrics
|
||||
, InjectInhibitMetrics, injectInhibitMetrics
|
||||
@ -215,7 +213,7 @@ injectedFilesBytes :: Counter
|
||||
injectedFilesBytes = unsafeRegister $ counter info
|
||||
where info = Info "uni2work_injected_files_bytes"
|
||||
"Size of files injected from upload cache into database"
|
||||
|
||||
|
||||
{-# NOINLINE rechunkedFiles #-}
|
||||
rechunkedFiles :: Counter
|
||||
rechunkedFiles = unsafeRegister $ counter info
|
||||
@ -269,46 +267,11 @@ favouritesSkippedDueToDBLoad :: Counter
|
||||
favouritesSkippedDueToDBLoad = unsafeRegister $ counter info
|
||||
where info = Info "uni2work_favourites_skipped_due_to_db_load_count"
|
||||
"Number of times this Uni2work-instance skipped generating FavouriteQuickActions due to database pressure"
|
||||
|
||||
|
||||
relabel :: Text -> Text
|
||||
-> SampleGroup -> SampleGroup
|
||||
relabel l s (SampleGroup i t ss) = SampleGroup i t . flip map ss $ \(Sample k lbls v) -> Sample k ((l, s) : filter (views _1 $ (/=) l) lbls) v
|
||||
|
||||
data ARCMetrics = ARCMetrics
|
||||
|
||||
data ARCLabel = ARCFileSource | ARCMemcachedLocal
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''ARCLabel $ camelToPathPiece' 1
|
||||
|
||||
arcMetrics :: Integral w
|
||||
=> ARCLabel
|
||||
-> ARCHandle k w v
|
||||
-> Metric ARCMetrics
|
||||
arcMetrics lbl ah = Metric $ return (ARCMetrics, collectARCMetrics)
|
||||
where
|
||||
labelArc = relabel "arc"
|
||||
|
||||
collectARCMetrics = map (labelArc $ toPathPiece lbl) <$> do
|
||||
(arc, _) <- readARCHandle ah
|
||||
return
|
||||
[ SampleGroup sizeInfo GaugeType
|
||||
[ Sample "arc_size" [("lru", "ghost-recent")] . encodeUtf8 . tshow $ arcGhostRecentSize arc
|
||||
, Sample "arc_size" [("lru", "recent")] . encodeUtf8 . tshow $ arcRecentSize arc
|
||||
, Sample "arc_size" [("lru", "frequent")] . encodeUtf8 . tshow $ arcFrequentSize arc
|
||||
, Sample "arc_size" [("lru", "ghost-frequent")] . encodeUtf8 . tshow $ arcGhostFrequentSize arc
|
||||
]
|
||||
, SampleGroup weightInfo GaugeType
|
||||
[ Sample "arc_weight" [("lru", "recent")] . encodeUtf8 . tshow . toInteger $ getARCRecentWeight arc
|
||||
, Sample "arc_weight" [("lru", "frequent")] . encodeUtf8 . tshow . toInteger $ getARCFrequentWeight arc
|
||||
]
|
||||
]
|
||||
sizeInfo = Info "arc_size"
|
||||
"Number of entries in the ARC LRUs"
|
||||
weightInfo = Info "arc_weight"
|
||||
"Sum of weights of entries in the ARC LRUs"
|
||||
|
||||
data LRUMetrics = LRUMetrics
|
||||
|
||||
data LRULabel = LRUFileSourcePrewarm
|
||||
@ -356,9 +319,9 @@ injectInhibitMetrics tvar = Metric $ return (InjectInhibitMetrics, collectInject
|
||||
[ Sample "uni2work_inject_inhibited_hashes_count" [] . encodeUtf8 . tshow . Set.size $ F.fold inhibits
|
||||
]
|
||||
]
|
||||
intervalsInfo = Info "uni2work_inject_inhibited_intervals_count"
|
||||
intervalsInfo = Info "uni2work_inject_inhibited_intervals_count"
|
||||
"Number of distinct time intervals in which we don't transfer some files from upload cache to db"
|
||||
hashesInfo = Info "uni2work_inject_inhibited_hashes_count"
|
||||
hashesInfo = Info "uni2work_inject_inhibited_hashes_count"
|
||||
"Number of files which we don't transfer from upload cache to db during some interval"
|
||||
|
||||
data PoolMetrics = PoolMetrics
|
||||
@ -392,12 +355,12 @@ poolMetrics lbl pool = Metric $ return (PoolMetrics, collectPoolMetrics)
|
||||
[ Sample "uni2work_pool_uses_count" [] . encodeUtf8 $ tshow usesCount
|
||||
]
|
||||
]
|
||||
|
||||
availableInfo = Info "uni2work_pool_available_count"
|
||||
|
||||
availableInfo = Info "uni2work_pool_available_count"
|
||||
"Number of open resources available for taking"
|
||||
inUseInfo = Info "uni2work_pool_in_use_count"
|
||||
inUseInfo = Info "uni2work_pool_in_use_count"
|
||||
"Number of resources currently in use"
|
||||
usesInfo = Info "uni2work_pool_uses_count"
|
||||
usesInfo = Info "uni2work_pool_uses_count"
|
||||
"Number of takes executed against the pool"
|
||||
|
||||
{-# NOINLINE databaseConnDuration #-}
|
||||
@ -407,7 +370,7 @@ databaseConnDuration = unsafeRegister . vector "label" $ histogram info buckets
|
||||
info = Info "uni2work_database_conn_duration_seconds"
|
||||
"Duration of use of a database connection from the pool"
|
||||
buckets = histogramBuckets 50e-6 5000
|
||||
|
||||
|
||||
data DBConnUseState = DBConnUseState
|
||||
{ dbConnUseStart :: !TimeSpec
|
||||
, dbConnUseLabel :: !CallStack
|
||||
@ -441,7 +404,7 @@ authTagEvaluationDuration = unsafeRegister . vector ("tag", "outcome", "handler"
|
||||
info = Info "uni2work_auth_tag_evaluation_duration_seconds"
|
||||
"Duration of auth tag evaluations"
|
||||
buckets = histogramBuckets 5e-6 1
|
||||
|
||||
|
||||
|
||||
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
|
||||
withHealthReportMetrics act = do
|
||||
@ -599,7 +562,7 @@ observeAuthTagEvaluation aTag handler act = do
|
||||
let outcome = case res of
|
||||
Right (_, outcome') -> outcome'
|
||||
Left _ -> OutcomeException
|
||||
|
||||
|
||||
liftIO . withLabel authTagEvaluationDuration (toPathPiece aTag, toPathPiece outcome, pack handler) . flip observe . realToFrac $ end - start
|
||||
|
||||
either throwIO (views _1 return) res
|
||||
|
||||
Loading…
Reference in New Issue
Block a user