diff --git a/config/settings.yml b/config/settings.yml index 472d86578..e5ae9c03f 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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 diff --git a/src/Application.hs b/src/Application.hs index ac5854c02..58156b47a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- 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 ***" diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 7e0812297..93b15fd70 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -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 diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 1084d181d..9dbc9de50 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- 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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 4abcd0ce2..fd8f3d6c9 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- 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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b8cb5a610..b331357e7 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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 diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index cd91cc79f..b8a4a8cd2 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel , Steffen Jost -- -- 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 diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 38f00d882..2877bd9af 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -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 ) diff --git a/src/Settings.hs b/src/Settings.hs index b37e2c1bb..800c3deea 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel ,-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- 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 diff --git a/src/Utils.hs b/src/Utils.hs index 5c68ba25a..35c15b39d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 diff --git a/src/Utils/ARC.hs b/src/Utils/ARC.hs deleted file mode 100644 index c8086c8f1..000000000 --- a/src/Utils/ARC.hs +++ /dev/null @@ -1,344 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen --- --- 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 diff --git a/src/Utils/LRU.hs b/src/Utils/LRU.hs index 8b8daa079..66517d70d 100644 --- a/src/Utils/LRU.hs +++ b/src/Utils/LRU.hs @@ -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 diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index e1f07dfc4..4eeefbb75 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen , Steffen Jost -- -- 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