fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(memcached): remove ARC cache entirely

Browse Source 
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:
Steffen Jost 2024-09-23 18:52:26 +02:00
parent 05638c2b51
commit a262921a7d
13 changed files with 122 additions and 604 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
config/settings.yml
View File

@ -204,9 +204,6 @@ memcached:
timeout: "_env:MEMCACHED_TIMEOUT:20" timeout: "_env:MEMCACHED_TIMEOUT:20"
expiration: "_env:MEMCACHED_EXPIRATION:300" expiration: "_env:MEMCACHED_EXPIRATION:300"
memcache-auth: true memcache-auth: true
memcached-local:
maximum-ghost: 512
maximum-weight: 104857600 # 100MiB
upload-cache: upload-cache:
host: "_env:UPLOAD_S3_HOST:" # should be optional, but all file transfers will be empty without an S3 cache host: "_env:UPLOAD_S3_HOST:" # should be optional, but all file transfers will be empty without an S3 cache

20
src/Application.hs
View File

@ -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 -- 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 qualified Utils.Pool as Custom
import Utils.Postgresql
import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
import qualified System.Clock as Clock import qualified System.Clock as Clock
import Utils.Avs (mkAvsQuery) import Utils.Avs (mkAvsQuery)
@ -219,10 +216,6 @@ makeFoundation appSettings''@AppSettings{..} = do
appJobState <- liftIO newEmptyTMVarIO appJobState <- liftIO newEmptyTMVarIO
appHealthReport <- liftIO $ newTVarIO Set.empty 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 appFileSourcePrewarm <- for appFileSourcePrewarmConf $ \PrewarmCacheConf{..} -> do
lh <- initLRUHandle precMaximumWeight lh <- initLRUHandle precMaximumWeight
void . Prometheus.register $ lruMetrics LRUFileSourcePrewarm lh void . Prometheus.register $ lruMetrics LRUFileSourcePrewarm lh
@ -239,7 +232,7 @@ makeFoundation appSettings''@AppSettings{..} = do
-- from there, and then create the real foundation. -- from there, and then create the real foundation.
let let
mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _ 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 tempFoundation = mkFoundation
(error "appSettings' forced in tempFoundation") (error "appSettings' forced in tempFoundation")
(error "connPool forced in tempFoundation") (error "connPool forced in tempFoundation")
@ -252,7 +245,6 @@ makeFoundation appSettings''@AppSettings{..} = do
(error "JSONWebKeySet forced in tempFoundation") (error "JSONWebKeySet forced in tempFoundation")
(error "ClusterID forced in tempFoundation") (error "ClusterID forced in tempFoundation")
(error "memcached forced in tempFoundation") (error "memcached forced in tempFoundation")
(error "memcachedLocal forced in tempFoundation")
(error "MinioConn forced in tempFoundation") (error "MinioConn forced in tempFoundation")
(error "VerpSecret forced in tempFoundation") (error "VerpSecret forced in tempFoundation")
(error "AuthKey forced in tempFoundation") (error "AuthKey forced in tempFoundation")
@ -337,12 +329,6 @@ makeFoundation appSettings''@AppSettings{..} = do
$logWarnS "setup" "Clearing memcached" $logWarnS "setup" "Clearing memcached"
liftIO $ Memcached.flushAll memcachedConn liftIO $ Memcached.flushAll memcachedConn
return AppMemcached{..} 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 appSessionStore <- mkSessionStore appSettings'' sqlPool `customRunSqlPool` sqlPool
@ -380,7 +366,7 @@ makeFoundation appSettings''@AppSettings{..} = do
$logDebugS "Runtime configuration" $ tshowCrop appSettings' $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 -- Return the foundation
$logInfoS "setup" "*** DONE ***" $logInfoS "setup" "*** DONE ***"

6
src/Foundation/Authorization.hs
View File

@ -313,7 +313,8 @@ isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM
dnf <- throwLeft $ routeAuthTags currentRoute dnf <- throwLeft $ routeAuthTags currentRoute
let eval :: forall m''. MonadAP m'' => AuthTagsEval m'' 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 in guardAuthResult <=< evalWriterT $ eval dnf mAuthId currentRoute isWrite
return False 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 noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
eval :: forall m'. MonadAP m' => AuthTagsEval m' 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' <- hoist apRunDB $ do
bearerAuthority' <- flip foldMapM bearerAuthority $ \case bearerAuthority' <- flip foldMapM bearerAuthority $ \case

16
src/Foundation/Type.hs
View File

@ -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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -11,8 +11,6 @@ module Foundation.Type
, _SessionStorageMemcachedSql, _SessionStorageAcid , _SessionStorageMemcachedSql, _SessionStorageAcid
, AppMemcached(..) , AppMemcached(..)
, _memcachedKey, _memcachedConn , _memcachedKey, _memcachedConn
, AppMemcachedLocal(..)
, _memcachedLocalARC
, SMTPPool , 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 , _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 , DB, DBRead, Form, MsgRenderer, MailM, DBFile
@ -38,9 +36,6 @@ import qualified Utils.Pool as Custom
import Utils.Metrics (DBConnUseState) 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 Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey)
import Utils.Avs (AvsQuery()) import Utils.Avs (AvsQuery())
@ -62,13 +57,6 @@ data AppMemcached = AppMemcached
makeLenses_ ''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 -- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
@ -93,11 +81,9 @@ data UniWorX = UniWorX
, appJSONWebKeySet :: Jose.JwkSet , appJSONWebKeySet :: Jose.JwkSet
, appHealthReport :: TVar (Set (UTCTime, HealthReport)) , appHealthReport :: TVar (Set (UTCTime, HealthReport))
, appMemcached :: Maybe AppMemcached , appMemcached :: Maybe AppMemcached
, appMemcachedLocal :: Maybe AppMemcachedLocal
, appUploadCache :: Maybe MinioConn , appUploadCache :: Maybe MinioConn
, appVerpSecret :: VerpSecret , appVerpSecret :: VerpSecret
, appAuthKey :: Auth.Key , appAuthKey :: Auth.Key
, appFileSourceARC :: Maybe (ARCHandle (FileContentChunkReference, (Int, Int)) Int ByteString)
, appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString) , appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString)
, appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference)) , appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference))
, appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey , appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey

4
src/Handler/Utils.hs
View File

@ -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 -- 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.Widgets as Handler.Utils
import Handler.Utils.Database as Handler.Utils import Handler.Utils.Database as Handler.Utils
import Handler.Utils.Occurrences 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.Files as Handler.Utils
import Handler.Utils.Download as Handler.Utils import Handler.Utils.Download as Handler.Utils
import Handler.Utils.AuthorshipStatement as Handler.Utils import Handler.Utils.AuthorshipStatement as Handler.Utils

2
src/Handler/Utils/Avs.hs
View File

@ -222,7 +222,7 @@ avsQueryNoCacheDefault qry = do
qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery) qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
throwLeftM $ qfun qry 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) , MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
avsQueryCached qry = avsQueryCached qry =
getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case

71
src/Handler/Utils/Files.hs
View File

@ -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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -18,8 +18,6 @@ import Foundation.Type
import Foundation.DB import Foundation.DB
import Utils.Metrics import Utils.Metrics
import Data.Monoid (First(..))
import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit.List as C (unfoldM) 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 System.FilePath (normalise, makeValid)
import Data.List (dropWhileEnd) import Data.List (dropWhileEnd)
import qualified Data.ByteString as ByteString
data SourceFilesException data SourceFilesException
@ -44,58 +41,36 @@ data SourceFilesException
makePrisms ''SourceFilesException makePrisms ''SourceFilesException
fileChunkARC :: ( MonadHandler m fileChunk :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
) )
=> Maybe Int => (FileContentChunkReference, (Int, Int))
-> (FileContentChunkReference, (Int, Int))
-> m (Maybe (ByteString, Maybe FileChunkStorage)) -> m (Maybe (ByteString, Maybe FileChunkStorage))
-> m (Maybe ByteString) -> m (Maybe ByteString)
fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do fileChunk k getChunkDB' = do
prewarm <- getsYesod appFileSourcePrewarm 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 Nothing -> do
chunk' <- getChunkDB' chunk' <- getChunkDB'
for chunk' $ \(chunk, mStorage) -> chunk <$ do for chunk' $ \(chunk, mStorage) -> chunk <$ do
$logDebugS "fileChunkARC" "No prewarm" $logDebugS "fileChunkARC" "Prewarm miss"
for_ mStorage $ \storage -> for_ mStorage $ \storage ->
let w = length chunk let w = length chunk
in liftIO $ observeSourcedChunk storage w 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
sourceFileDB :: forall m. 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) 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 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 in getChunkDB' <|> getChunkMinio
chunk <- fileChunkARC Nothing (chunkHash, (start, dbChunksize)) getChunkDB chunk <- fileChunk (chunkHash, (start, dbChunksize)) getChunkDB
case chunk of case chunk of
Just c | olength c <= 0 -> return Nothing Just c | olength c <= 0 -> return Nothing
Just c -> do 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 let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectOne . E.from $ \fileContentChunk -> do
E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash
return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize) 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 case chunk of
Nothing -> throwM SourceFilesContentUnavailable Nothing -> throwM SourceFilesContentUnavailable
Just c -> do Just c -> do

162
src/Handler/Utils/Memcached.hs
View File

@ -11,7 +11,6 @@ module Handler.Utils.Memcached
, memcachedHere, memcachedByHere , memcachedHere, memcachedByHere
, memcachedSet, memcachedGet , memcachedSet, memcachedGet
, memcachedInvalidate, memcachedByInvalidate, memcachedFlushAll , memcachedInvalidate, memcachedByInvalidate, memcachedFlushAll
, manageMemcachedLocalInvalidations
, memcachedByGet, memcachedBySet , memcachedByGet, memcachedBySet
, memcachedTimeout, memcachedTimeoutBy , memcachedTimeout, memcachedTimeoutBy
, memcachedTimeoutHere, memcachedTimeoutByHere , memcachedTimeoutHere, memcachedTimeoutByHere
@ -45,11 +44,9 @@ import qualified Data.Set as Set
import qualified Data.ByteArray as BA import qualified Data.ByteArray as BA
import qualified Data.ByteString.Base64 as Base64
import Language.Haskell.TH hiding (Type) import Language.Haskell.TH hiding (Type)
import Data.Typeable (typeRep, typeRepFingerprint) import Data.Typeable (typeRep)
import Type.Reflection (typeOf, TypeRep) import Type.Reflection (typeOf, TypeRep)
import qualified Type.Reflection as Refl (typeRep) import qualified Type.Reflection as Refl (typeRep)
import Data.Type.Equality (TestEquality(..)) import Data.Type.Equality (TestEquality(..))
@ -72,10 +69,6 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)
import GHC.Fingerprint import GHC.Fingerprint
import Utils.Postgresql
import UnliftIO.Concurrent (threadDelay)
type Expiry = Either UTCTime DiffTime type Expiry = Either UTCTime DiffTime
@ -169,68 +162,49 @@ memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do
memcachedByGet :: forall a k m. memcachedByGet :: forall a k m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> k -> m (Maybe a) => k -> m (Maybe a)
memcachedByGet (Binary.encode -> k) = runMaybeT $ arc <|> memcache memcachedByGet (Binary.encode -> k) = runMaybeT $ do
where AppMemcached{..} <- MaybeT $ getsYesod appMemcached
arc = do let cKey = toMemcachedKey memcachedKey (Proxy @a) k
AppMemcachedLocal{..} <- MaybeT $ getsYesod appMemcachedLocal encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey memcachedConn
res <- hoistMaybe . preview (_1 . _NFDynamic) <=< hoistMaybe <=< cachedARC' memcachedLocalARC (typeRepFingerprint . typeRep $ Proxy @a, k) $ \mPrev -> do -- $logDebugS "memcached" "Cache hit"
prev@((_, prevExpiry), _) <- hoistMaybe mPrev
$logDebugS "memcached" "Cache hit (local ARC)" let withExp doExp = do
lift . runMaybeT $ do -- To delete from ARC upon expiry MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp
for_ prevExpiry $ \expiry -> do $logDebugS "memcached" "Decode valid"
for_ mExpiry $ \expiry -> do
now <- liftIO getPOSIXTime now <- liftIO getPOSIXTime
guard $ expiry > now guard $ expiry > now + clockLeniency
return prev $logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
$logDebugS "memcached" "All valid (local ARC)" let aad = memcachedAAD cKey mExpiry
return res decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad
memcache = do
AppMemcached{..} <- MaybeT $ getsYesod appMemcached
localARC <- getsYesod appMemcachedLocal
let cKey = toMemcachedKey memcachedKey (Proxy @a) k
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 withExp True <|> withExp False
MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp where
$logDebugS "memcached" "Decode valid" runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of
for_ mExpiry $ \expiry -> do Right (bs', _, x) | null bs' -> Just x
now <- liftIO getPOSIXTime _other -> Nothing
guard $ expiry > now + clockLeniency
$logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
let aad = memcachedAAD cKey mExpiry
decrypted <- hoistMaybe $ AEAD.aeadOpen memcachedKey mNonce mCiphertext aad
$logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration" clockLeniency :: NominalDiffTime
clockLeniency = 2
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
memcachedBySet :: forall a k m. memcachedBySet :: forall a k m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> Maybe Expiry -> k -> a -> m () => Maybe Expiry -> k -> a -> m ()
@ -239,7 +213,7 @@ memcachedBySet = ((void .) .) . memcachedBySet'
memcachedBySet' :: forall a k m. memcachedBySet' :: forall a k m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> Maybe Expiry -> k -> a -> m (Maybe ByteString) => Maybe Expiry -> k -> a -> m (Maybe ByteString)
@ -252,7 +226,7 @@ memcachedBySet' mExp (Binary.encode -> k) v = do
Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime
mConn <- getsYesod appMemcached mConn <- getsYesod appMemcached
bsKey <- for mConn $ \AppMemcached{..} -> do for mConn $ \AppMemcached{..} -> do
mNonce <- liftIO AEAD.newNonce mNonce <- liftIO AEAD.newNonce
let cKey = toMemcachedKey memcachedKey (Proxy @a) k let cKey = toMemcachedKey memcachedKey (Proxy @a) k
aad = memcachedAAD cKey mExpiry aad = memcachedAAD cKey mExpiry
@ -261,36 +235,17 @@ memcachedBySet' mExp (Binary.encode -> k) v = do
$logDebugS "memcached" $ "Cache store: " <> tshow mExpiry $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry
return cKey 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. memcachedByInvalidate :: forall a k m p.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, Typeable a , Typeable a
, Binary k , Binary k
) )
=> k -> p a -> m () => k -> p a -> m ()
memcachedByInvalidate (Binary.encode -> k) _ = arc >> memcache memcachedByInvalidate (Binary.encode -> k) _ = maybeT_ $ do
where AppMemcached{..} <- MaybeT $ getsYesod appMemcached
memcache = maybeT_ $ do let cKey = toMemcachedKey memcachedKey (Proxy @a) k
AppMemcached{..} <- MaybeT $ getsYesod appMemcached hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey memcachedConn
let cKey = toMemcachedKey memcachedKey (Proxy @a) k $logDebugS "memcached" "Cache invalidation"
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)"
data MemcachedLocalInvalidateMsg = MemcachedLocalInvalidateMsg data MemcachedLocalInvalidateMsg = MemcachedLocalInvalidateMsg
{ mLocalInvalidateType :: Fingerprint { mLocalInvalidateType :: Fingerprint
@ -308,6 +263,7 @@ instance Binary MemcachedLocalInvalidateMsg where
Binary.putWord64le w2 Binary.putWord64le w2
Binary.putLazyByteString mLocalInvalidateKey Binary.putLazyByteString mLocalInvalidateKey
{-
manageMemcachedLocalInvalidations :: ( MonadUnliftIO m manageMemcachedLocalInvalidations :: ( MonadUnliftIO m
, MonadLogger m , MonadLogger m
) )
@ -330,7 +286,7 @@ manageMemcachedLocalInvalidations localARC iQueue = PostgresqlChannelManager
let (mLocalInvalidateType, mLocalInvalidateKey) = i let (mLocalInvalidateType, mLocalInvalidateKey) = i
return . Base64.encode . toStrict $ Binary.encode MemcachedLocalInvalidateMsg{..} return . Base64.encode . toStrict $ Binary.encode MemcachedLocalInvalidateMsg{..}
} }
-}
newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a } newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a }
deriving newtype (Eq, Ord, Show, Binary) deriving newtype (Eq, Ord, Show, Binary)
@ -338,14 +294,14 @@ instance NFData a => NFData (MemcachedUnkeyed a) where
rnf = rnf . unMemcachedUnkeyed rnf = rnf . unMemcachedUnkeyed
memcachedGet :: ( MonadHandler m, HandlerSite m ~ UniWorX memcachedGet :: ( MonadHandler m, HandlerSite m ~ UniWorX
, Typeable a, Binary a, NFData a , Typeable a, Binary a
) )
=> m (Maybe a) => m (Maybe a)
memcachedGet = fmap unMemcachedUnkeyed <$> memcachedByGet () memcachedGet = fmap unMemcachedUnkeyed <$> memcachedByGet ()
memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
) )
=> Maybe Expiry -> a -> m () => Maybe Expiry -> a -> m ()
memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed
@ -366,7 +322,7 @@ memcachedWith (doGet, doSet) act = maybeM (act >>= doSet) pure doGet
memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
) )
=> Maybe Expiry -> m a -> m a => Maybe Expiry -> m a -> m a
memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x) 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. memcachedBy :: forall a m k.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> Maybe Expiry -> k -> m a -> m a => Maybe Expiry -> k -> m a -> m a
@ -394,7 +350,7 @@ newtype MemcachedKeyClassStore = MemcachedKeyClassStore{ unMemcachedKeyClassStor
memcachedByClass :: forall a m k. memcachedByClass :: forall a m k.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> MemcachedKeyClass -> Maybe Expiry -> k -> m a -> m a => 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. memcachedLimited :: forall a m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
) )
=> Word64 -- ^ burst-size (tokens) => Word64 -- ^ burst-size (tokens)
-> Word64 -- ^ avg. inverse rate (usec/token) -> Word64 -- ^ avg. inverse rate (usec/token)
@ -513,7 +469,7 @@ memcachedLimited burst rate tokens mExp = memcachedLimitedWith (memcachedGet, me
memcachedLimitedKey :: forall a k' m. memcachedLimitedKey :: forall a k' m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Typeable k', Hashable k', Eq k' , Typeable k', Hashable k', Eq k'
) )
=> k' => k'
@ -528,7 +484,7 @@ memcachedLimitedKey lK burst rate tokens mExp = memcachedLimitedWith (memcachedG
memcachedLimitedBy :: forall a k m. memcachedLimitedBy :: forall a k m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> Word64 -- ^ burst-size (tokens) => Word64 -- ^ burst-size (tokens)
@ -543,7 +499,7 @@ memcachedLimitedBy burst rate tokens mExp k = memcachedLimitedWith (memcachedByG
memcachedLimitedKeyBy :: forall a k' k m. memcachedLimitedKeyBy :: forall a k' k m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Typeable k', Hashable k', Eq k' , Typeable k', Hashable k', Eq k'
, Binary k , Binary k
) )
@ -581,7 +537,7 @@ memcachedLimitedKeyByHere = do
memcacheAuth :: forall m k a. memcacheAuth :: forall m k a.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> k => k
@ -602,7 +558,7 @@ memcacheAuth k mx = cachedByBinary k $ do
memcacheAuth' :: forall a m k. memcacheAuth' :: forall a m k.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> Expiry => Expiry
@ -614,7 +570,7 @@ memcacheAuth' exp k = memcacheAuth k . (<* tell (Just $ Min exp)) . lift
memcacheAuthMax :: forall m k a. memcacheAuthMax :: forall m k a.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> Expiry => Expiry
@ -728,7 +684,7 @@ memcachedTimeout :: ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, MonadUnliftIO m , MonadUnliftIO m
, Typeable k'', Hashable k'', Eq k'' , 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) => Maybe Expiry -> DiffTime -> k'' -> m a -> m (Maybe a)
memcachedTimeout mExp = memcachedTimeoutWith (memcachedGet, memcachedSet mExp) memcachedTimeout mExp = memcachedTimeoutWith (memcachedGet, memcachedSet mExp)
@ -737,7 +693,7 @@ memcachedTimeoutBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, MonadUnliftIO m , MonadUnliftIO m
, Typeable k'', Hashable k'', Eq k'' , Typeable k'', Hashable k'', Eq k''
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> Maybe Expiry -> DiffTime -> k'' -> k -> m a -> m (Maybe a) => Maybe Expiry -> DiffTime -> k'' -> k -> m a -> m (Maybe a)
@ -758,7 +714,7 @@ memcachedLimitedTimeout :: forall a k'' m.
, MonadThrow m , MonadThrow m
, MonadUnliftIO m , MonadUnliftIO m
, Typeable k'', Hashable k'', Eq k'' , Typeable k'', Hashable k'', Eq k''
, Typeable a, Binary a, NFData a , Typeable a, Binary a
) )
=> Word64 -- ^ burst-size (tokens) => Word64 -- ^ burst-size (tokens)
-> Word64 -- ^ avg. inverse rate (usec/token) -> Word64 -- ^ avg. inverse rate (usec/token)
@ -775,7 +731,7 @@ memcachedLimitedKeyTimeout :: forall a k' k'' m.
, MonadThrow m , MonadThrow m
, MonadUnliftIO m , MonadUnliftIO m
, Typeable k'', Hashable k'', Eq k'' , Typeable k'', Hashable k'', Eq k''
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Typeable k', Hashable k', Eq k' , Typeable k', Hashable k', Eq k'
) )
=> k' => k'
@ -794,7 +750,7 @@ memcachedLimitedTimeoutBy :: forall a k'' k m.
, MonadThrow m , MonadThrow m
, MonadUnliftIO m , MonadUnliftIO m
, Typeable k'', Hashable k'', Eq k'' , Typeable k'', Hashable k'', Eq k''
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Binary k , Binary k
) )
=> Word64 -- ^ burst-size (tokens) => Word64 -- ^ burst-size (tokens)
@ -813,7 +769,7 @@ memcachedLimitedKeyTimeoutBy :: forall a k' k'' k m.
, MonadThrow m , MonadThrow m
, MonadUnliftIO m , MonadUnliftIO m
, Typeable k'', Hashable k'', Eq k'' , Typeable k'', Hashable k'', Eq k''
, Typeable a, Binary a, NFData a , Typeable a, Binary a
, Typeable k', Hashable k', Eq k' , Typeable k', Hashable k', Eq k'
, Binary k , Binary k
) )

4
src/Settings.hs
View File

@ -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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -207,7 +207,6 @@ data AppSettings = AppSettings
, appMemcachedConf :: Maybe MemcachedConf , appMemcachedConf :: Maybe MemcachedConf
, appMemcacheAuth :: Bool , appMemcacheAuth :: Bool
, appMemcachedLocalConf :: Maybe (ARCConf Int)
, appUploadCacheConf :: Maybe Minio.ConnectInfo , appUploadCacheConf :: Maybe Minio.ConnectInfo
, appUploadCacheBucket, appUploadTmpBucket :: Minio.Bucket , appUploadCacheBucket, appUploadTmpBucket :: Minio.Bucket
@ -688,7 +687,6 @@ instance FromJSON AppSettings where
appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached" appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached"
appMemcacheAuth <- o .:? "memcache-auth" .!= False appMemcacheAuth <- o .:? "memcache-auth" .!= False
appMemcachedLocalConf <- assertM isValidARCConf <$> o .:? "memcached-local"
appMailFrom <- o .: "mail-from" appMailFrom <- o .: "mail-from"
appMailEnvelopeFrom <- o .:? "mail-envelope-from" .!= addressEmail appMailFrom appMailEnvelopeFrom <- o .:? "mail-envelope-from" .!= addressEmail appMailFrom

1
src/Utils.hs
View File

@ -44,7 +44,6 @@ import Utils.I18n as Utils
import Utils.NTop as Utils import Utils.NTop as Utils
import Utils.HttpConditional as Utils import Utils.HttpConditional as Utils
import Utils.Persist as Utils import Utils.Persist as Utils
import Utils.ARC as Utils
import Utils.LRU as Utils import Utils.LRU as Utils
import Utils.Set as Utils import Utils.Set as Utils

344
src/Utils/ARC.hs
View File

@ -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

32
src/Utils/LRU.hs
View File

@ -66,11 +66,11 @@ initLRU :: forall k t w v.
-> (LRU k t w v, LRUTick) -> (LRU k t w v, LRUTick)
initLRU lruMaximumWeight initLRU lruMaximumWeight
| lruMaximumWeight < 0 = error "initLRU given negative maximum weight" | lruMaximumWeight < 0 = error "initLRU given negative maximum weight"
| otherwise = (, initialLRUTick) LRU | otherwise = (lru, initialLRUTick)
{ lruStore = OrdPSQ.empty where lru = LRU { lruStore = OrdPSQ.empty
, lruWeight = 0 , lruWeight = 0
, lruMaximumWeight , lruMaximumWeight
} }
insertLRU :: forall k t w v. insertLRU :: forall k t w v.
( Ord k, Ord t ( Ord k, Ord t
@ -84,18 +84,18 @@ insertLRU :: forall k t w v.
insertLRU k t newVal oldLRU@LRU{..} now insertLRU k t newVal oldLRU@LRU{..} now
| later <= initialLRUTick = uncurry (insertLRU k t newVal) $ initLRU lruMaximumWeight | later <= initialLRUTick = uncurry (insertLRU k t newVal) $ initLRU lruMaximumWeight
| Just (_, w) <- newVal, w > lruMaximumWeight = (oldLRU, now) | Just (_, w) <- newVal, w > lruMaximumWeight = (oldLRU, now)
| Just (_, w) <- newVal = (, later) $ | Just (_, w) <- newVal = (, later) $
let (lruStore', lruWeight') = evictToSize (lruMaximumWeight - w) lruStore lruWeight let (lruStore', lruWeight') = evictToSize (lruMaximumWeight - w) lruStore lruWeight
(fromMaybe 0 . preview (_Just . _2 . _2) -> oldWeight, lruStore'') (fromMaybe 0 . preview (_Just . _2 . _2) -> oldWeight, lruStore'')
= OrdPSQ.alter (, ((t, now), ) <$> newVal) k lruStore' = OrdPSQ.alter (, ((t, now), ) <$> newVal) k lruStore'
in oldLRU in oldLRU { lruStore = lruStore''
{ lruStore = lruStore'' , lruWeight = lruWeight' - oldWeight + w
, lruWeight = lruWeight' - oldWeight + w }
} | Just (_, (_, w), lruStore') <- OrdPSQ.deleteView k lruStore =
| Just (_, (_, w), lruStore') <- OrdPSQ.deleteView k lruStore = (, now) oldLRU let lru = oldLRU { lruStore = lruStore'
{ lruStore = lruStore' , lruWeight = lruWeight - w
, lruWeight = lruWeight - w }
} in (lru, now)
| otherwise = (oldLRU, now) | otherwise = (oldLRU, now)
where where
later :: LRUTick later :: LRUTick
@ -127,9 +127,9 @@ touchLRU k t oldLRU@LRU{..} now
, later <= initialLRUTick = (, Just v) . uncurry (insertLRU k t $ Just v) $ initLRU lruMaximumWeight , later <= initialLRUTick = (, Just v) . uncurry (insertLRU k t $ Just v) $ initLRU lruMaximumWeight
| (Just (_, v), lruStore') <- altered = ((oldLRU{ lruStore = lruStore' }, later), Just v) | (Just (_, v), lruStore') <- altered = ((oldLRU{ lruStore = lruStore' }, later), Just v)
| otherwise = ((oldLRU, now), Nothing) | otherwise = ((oldLRU, now), Nothing)
where where
altered = OrdPSQ.alter (\oldVal -> (oldVal, over _1 (max (t, later)) <$> oldVal)) k lruStore altered = OrdPSQ.alter (\oldVal -> (oldVal, over _1 (max (t, later)) <$> oldVal)) k lruStore
later :: LRUTick later :: LRUTick
later = over getLRUTick succ now later = over getLRUTick succ now

61
src/Utils/Metrics.hs
View File

@ -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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -19,8 +19,6 @@ module Utils.Metrics
, observeDeletedUnreferencedFiles, observeDeletedUnreferencedChunks, observeInjectedFiles, observeRechunkedFiles , observeDeletedUnreferencedFiles, observeDeletedUnreferencedChunks, observeInjectedFiles, observeRechunkedFiles
, registerJobWorkerQueueDepth , registerJobWorkerQueueDepth
, observeMissingFiles , observeMissingFiles
, ARCMetrics, ARCLabel(..)
, arcMetrics
, LRUMetrics, LRULabel(..) , LRUMetrics, LRULabel(..)
, lruMetrics , lruMetrics
, InjectInhibitMetrics, injectInhibitMetrics , InjectInhibitMetrics, injectInhibitMetrics
@ -215,7 +213,7 @@ injectedFilesBytes :: Counter
injectedFilesBytes = unsafeRegister $ counter info injectedFilesBytes = unsafeRegister $ counter info
where info = Info "uni2work_injected_files_bytes" where info = Info "uni2work_injected_files_bytes"
"Size of files injected from upload cache into database" "Size of files injected from upload cache into database"
{-# NOINLINE rechunkedFiles #-} {-# NOINLINE rechunkedFiles #-}
rechunkedFiles :: Counter rechunkedFiles :: Counter
rechunkedFiles = unsafeRegister $ counter info rechunkedFiles = unsafeRegister $ counter info
@ -269,46 +267,11 @@ favouritesSkippedDueToDBLoad :: Counter
favouritesSkippedDueToDBLoad = unsafeRegister $ counter info favouritesSkippedDueToDBLoad = unsafeRegister $ counter info
where info = Info "uni2work_favourites_skipped_due_to_db_load_count" where info = Info "uni2work_favourites_skipped_due_to_db_load_count"
"Number of times this Uni2work-instance skipped generating FavouriteQuickActions due to database pressure" "Number of times this Uni2work-instance skipped generating FavouriteQuickActions due to database pressure"
relabel :: Text -> Text relabel :: Text -> Text
-> SampleGroup -> SampleGroup -> 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 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 LRUMetrics = LRUMetrics
data LRULabel = LRUFileSourcePrewarm 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 [ 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" "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" "Number of files which we don't transfer from upload cache to db during some interval"
data PoolMetrics = PoolMetrics data PoolMetrics = PoolMetrics
@ -392,12 +355,12 @@ poolMetrics lbl pool = Metric $ return (PoolMetrics, collectPoolMetrics)
[ Sample "uni2work_pool_uses_count" [] . encodeUtf8 $ tshow usesCount [ 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" "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" "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" "Number of takes executed against the pool"
{-# NOINLINE databaseConnDuration #-} {-# NOINLINE databaseConnDuration #-}
@ -407,7 +370,7 @@ databaseConnDuration = unsafeRegister . vector "label" $ histogram info buckets
info = Info "uni2work_database_conn_duration_seconds" info = Info "uni2work_database_conn_duration_seconds"
"Duration of use of a database connection from the pool" "Duration of use of a database connection from the pool"
buckets = histogramBuckets 50e-6 5000 buckets = histogramBuckets 50e-6 5000
data DBConnUseState = DBConnUseState data DBConnUseState = DBConnUseState
{ dbConnUseStart :: !TimeSpec { dbConnUseStart :: !TimeSpec
, dbConnUseLabel :: !CallStack , dbConnUseLabel :: !CallStack
@ -441,7 +404,7 @@ authTagEvaluationDuration = unsafeRegister . vector ("tag", "outcome", "handler"
info = Info "uni2work_auth_tag_evaluation_duration_seconds" info = Info "uni2work_auth_tag_evaluation_duration_seconds"
"Duration of auth tag evaluations" "Duration of auth tag evaluations"
buckets = histogramBuckets 5e-6 1 buckets = histogramBuckets 5e-6 1
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
withHealthReportMetrics act = do withHealthReportMetrics act = do
@ -599,7 +562,7 @@ observeAuthTagEvaluation aTag handler act = do
let outcome = case res of let outcome = case res of
Right (_, outcome') -> outcome' Right (_, outcome') -> outcome'
Left _ -> OutcomeException Left _ -> OutcomeException
liftIO . withLabel authTagEvaluationDuration (toPathPiece aTag, toPathPiece outcome, pack handler) . flip observe . realToFrac $ end - start liftIO . withLabel authTagEvaluationDuration (toPathPiece aTag, toPathPiece outcome, pack handler) . flip observe . realToFrac $ end - start
either throwIO (views _1 return) res either throwIO (views _1 return) res