diff --git a/lib/shelley/bench/Latency.hs b/lib/shelley/bench/Latency.hs index 52341610825..9588bd79fbc 100644 --- a/lib/shelley/bench/Latency.hs +++ b/lib/shelley/bench/Latency.hs @@ -69,7 +69,7 @@ import Cardano.Wallet.Shelley.Launch.Cluster ( LocalClusterConfig (..) , LogFileConfig (..) , RunningNode (..) - , debugConfigFromEnv + , listPoolsConfigFromEnv , sendFaucetAssetsTo , sendFaucetFundsTo , walletListenFromEnv @@ -465,7 +465,7 @@ withShelleyServer tracers action = do onClusterStart act db (RunningNode conn block0 (np, vData)) = do listen <- walletListenFromEnv - debug <- debugConfigFromEnv + cacheListPools <- listPoolsConfigFromEnv serveWallet (SomeNetworkDiscriminant $ Proxy @'Mainnet) tracers @@ -477,7 +477,7 @@ withShelleyServer tracers action = do Nothing Nothing Nothing - (Just debug) + cacheListPools conn block0 (np, vData) diff --git a/lib/shelley/exe/cardano-wallet.hs b/lib/shelley/exe/cardano-wallet.hs index 66386c89cf2..56260d84b46 100644 --- a/lib/shelley/exe/cardano-wallet.hs +++ b/lib/shelley/exe/cardano-wallet.hs @@ -107,6 +107,8 @@ import Cardano.Wallet.Version ( GitRevision, Version, showFullVersion ) import Control.Applicative ( Const (..), optional ) +import Control.Cache + ( CacheConfig (..) ) import Control.Exception.Base ( AsyncException (..) ) import Control.Monad @@ -120,14 +122,17 @@ import Data.Bifunctor import Data.Text ( Text ) import Data.Text.Class - ( ToText (..) ) + ( ToText (..), showT ) import Network.URI ( URI ) import Options.Applicative ( CommandFields , Mod , Parser + , auto , command + , flag' + , help , helper , info , internal @@ -135,7 +140,9 @@ import Options.Applicative , metavar , option , progDesc + , showDefaultWith , value + , (<|>) ) import System.Environment ( getArgs, getExecutablePath ) @@ -186,6 +193,7 @@ data ServeArgs = ServeArgs , _enableShutdownHandler :: Bool , _poolMetadataSourceOpt :: Maybe PoolMetadataSource , _tokenMetadataSourceOpt :: Maybe TokenMetadataServer + , _cacheListPools :: CacheConfig , _logging :: LoggingOptions TracerSeverities } deriving (Show) @@ -196,6 +204,17 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty where helper' = helperTracing tracerDescriptions + cacheListPoolsOption = (CacheTTL <$> option auto + ( long "cache-listpools-ttl" + <> metavar "TTL" + <> help "Cache time to live (TTL) for stake-pools listing (number in seconds)." + <> value (let one_hour = 60*60 in one_hour) + <> showDefaultWith showT + )) <|> flag' NoCache + ( long "no-cache-listpools" + <> help "Do not cache the stake-pools listing." + ) + cmd = fmap exec $ ServeArgs <$> hostPreferenceOption <*> listenOption @@ -207,6 +226,7 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty <*> shutdownHandlerFlag <*> optional poolMetadataSourceOption <*> optional tokenMetadataSourceOption + <*> cacheListPoolsOption <*> loggingOptions tracerSeveritiesOption exec :: ServeArgs -> IO () @@ -221,6 +241,7 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty enableShutdownHandler poolMetadataFetching tokenMetadataServerURI + cacheListPools logOpt) = do withTracers logOpt $ \tr tracers -> do withShutdownHandlerMaybe tr enableShutdownHandler $ do @@ -245,7 +266,7 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty tlsConfig (fmap Settings poolMetadataFetching) tokenMetadataServerURI - Nothing + cacheListPools conn block0 (gp, vData) diff --git a/lib/shelley/exe/local-cluster.hs b/lib/shelley/exe/local-cluster.hs index d369fc1a440..a50001cd8e1 100644 --- a/lib/shelley/exe/local-cluster.hs +++ b/lib/shelley/exe/local-cluster.hs @@ -48,7 +48,7 @@ import Cardano.Wallet.Shelley.Launch import Cardano.Wallet.Shelley.Launch.Cluster ( ClusterLog (..) , RunningNode (..) - , debugConfigFromEnv + , listPoolsConfigFromEnv , localClusterConfigFromEnv , moveInstantaneousRewardsTo , oneMillionAda @@ -241,7 +241,7 @@ main = withLocalClusterSetup $ \dir clusterLogs walletLogs -> createDirectory db listen <- walletListenFromEnv tokenMetadataServer <- tokenMetadataServerFromEnv - debug <- debugConfigFromEnv + cacheListPools <- listPoolsConfigFromEnv prometheusUrl <- (maybe "none" (\(h, p) -> T.pack h <> ":" <> toText @(Port "Prometheus") p) @@ -263,7 +263,7 @@ main = withLocalClusterSetup $ \dir clusterLogs walletLogs -> Nothing Nothing tokenMetadataServer - (Just debug) + cacheListPools socketPath block0 (gp, vData) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index 32ee21922f4..b61097b783a 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs @@ -26,7 +26,6 @@ module Cardano.Wallet.Shelley ( SomeNetworkDiscriminant (..) - , DebugConfig (..) , serveWallet -- * Tracing @@ -151,7 +150,12 @@ import Cardano.Wallet.Transaction import Control.Applicative ( Const (..) ) import Control.Cache - ( CacheWorker (..), MkCacheWorker, don'tCacheWorker, newCacheWorker ) + ( CacheConfig (..) + , CacheWorker (..) + , MkCacheWorker + , don'tCacheWorker + , newCacheWorker + ) import Control.Monad ( forM_, void ) import Control.Tracer @@ -166,8 +170,6 @@ import Data.Text ( Text ) import Data.Text.Class ( ToText (..) ) -import Data.Time.Clock - ( NominalDiffTime ) import GHC.Generics ( Generic ) import Network.Ntp @@ -224,19 +226,13 @@ data SomeNetworkDiscriminant where deriving instance Show SomeNetworkDiscriminant -{- HLINT ignore DebugConfig "Use newtype instead of data" -} --- | Various settings that modify the behavior 'serveWallet' in order --- to make it easier to test. -data DebugConfig = DebugConfig - { cacheLocalStateQueryTTL :: Maybe NominalDiffTime - -- ^ Time to live (TTL) for caching local state queries ('LSQ') - -- to a cardano-node. - -- If this value is 'Nothing', then queries are /not/ cached. - -- - -- Some functions such as 'listStakePools' will query - -- the node at the program start and cache the value - -- in order to become more responsive. - } deriving (Show, Generic, Eq) +-- | Configuration of caching of local state queries. +-- +-- The function 'listStakePools' will query +-- the node at the program start and cache the value +-- in order to become more responsive. +-- This type specifies how this caching should be done. +type CacheConfigLocalStateQuery = CacheConfig -- | The @cardano-wallet@ main function. It takes the configuration -- which was passed from the CLI and environment and starts all components of @@ -261,8 +257,8 @@ serveWallet -> Maybe Settings -- ^ Settings to be set at application start, will be written into DB. -> Maybe TokenMetadataServer - -> Maybe DebugConfig - -- ^ Optional behavior change to simplify debugging and testing. + -> CacheConfigLocalStateQuery + -- ^ How to cache the 'listStakePools' local state query. -> CardanoNodeConn -- ^ Socket for communicating with the node -> Block @@ -285,7 +281,7 @@ serveWallet tlsConfig settings tokenMetaUri - mDebugConfig + cacheListPools conn block0 (np, vData) @@ -314,7 +310,8 @@ serveWallet multisigApi <- apiLayer txLayerUdefined nl Server.idleWorker - withPoolsMonitoring databaseDir np nl mDebugConfig $ \spl -> do + withPoolsMonitoring databaseDir np nl cacheListPools $ + \spl -> do startServer proxy socket @@ -365,10 +362,10 @@ serveWallet :: Maybe FilePath -> NetworkParameters -> NetworkLayer IO (CardanoBlock StandardCrypto) - -> Maybe DebugConfig + -> CacheConfig -> (StakePoolLayer -> IO a) -> IO a - withPoolsMonitoring dir (NetworkParameters _ sp _) nl mdebug action = + withPoolsMonitoring dir (NetworkParameters _ sp _) nl cachepools action = Pool.withDecoratedDBLayer poolDatabaseDecorator poolsDbTracer @@ -405,16 +402,11 @@ serveWallet withRetries maction = Retry.recovering policy (Retry.skipAsyncExceptions ++ [traceEx]) (\_ -> maction) let mkCacheWorker :: forall a. MkCacheWorker a - mkCacheWorker = case mdebug of - Just DebugConfig{cacheLocalStateQueryTTL=Nothing} -> - don'tCacheWorker - Just DebugConfig{cacheLocalStateQueryTTL=Just ttl} -> - newCacheWorker ttl grace . withRetries - Nothing -> -- production environment - newCacheWorker one_hour grace . withRetries + mkCacheWorker = case cachepools of + NoCache -> don'tCacheWorker + CacheTTL ttl -> newCacheWorker ttl grace . withRetries where grace = 3 -- seconds - one_hour = 60*60 -- seconds (worker, spl) <- newStakePoolLayer gcStatus nl db mkCacheWorker restartMetadataThread diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Launch/Cluster.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Launch/Cluster.hs index a88ecb0d1a6..ca6172fb25a 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Launch/Cluster.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Launch/Cluster.hs @@ -55,7 +55,7 @@ module Cardano.Wallet.Shelley.Launch.Cluster , testLogDirFromEnv , walletListenFromEnv , tokenMetadataServerFromEnv - , debugConfigFromEnv + , listPoolsConfigFromEnv -- * Faucets , sendFaucetFundsTo @@ -131,14 +131,14 @@ import Cardano.Wallet.Primitive.Types.TokenQuantity ( TokenQuantity (..) ) import Cardano.Wallet.Primitive.Types.Tx ( TxOut ) -import Cardano.Wallet.Shelley - ( DebugConfig (..) ) import Cardano.Wallet.Shelley.Compatibility ( StandardShelley ) import Cardano.Wallet.Shelley.Launch ( TempDirLog (..), envFromText, isEnvSet, lookupEnvNonEmpty ) import Cardano.Wallet.Unsafe ( unsafeFromHex, unsafeRunExceptT ) +import Control.Cache + ( CacheConfig (..) ) import Control.Monad ( forM, forM_, liftM2, replicateM, replicateM_, unless, void, when, (>=>) ) import Control.Monad.Trans.Except @@ -290,15 +290,16 @@ tokenMetadataServerFromEnv = envFromText "TOKEN_METADATA_SERVER" >>= \case Just (Right s) -> pure (Just s) Just (Left e) -> die $ show e --- | Collect 'DebugConfig' from environment variables. -debugConfigFromEnv :: IO DebugConfig -debugConfigFromEnv = do - mttl <- envFromText "CACHE_LOCALSTATEQUERY_TTL" >>= \case - Nothing -> pure $ Just 6 -- default value - Just (Right s) -> pure $ Just s +-- | Collect @--cache-listpools-ttl@ and @--no-cache-listpools@ options +-- from environment variables. +listPoolsConfigFromEnv :: IO CacheConfig +listPoolsConfigFromEnv = do + ttl <- envFromText "CACHE_LISTPOOLS_TTL" >>= \case + Nothing -> pure $ CacheTTL 6 -- default value for testing + Just (Right s) -> pure $ CacheTTL s Just (Left e) -> die $ show e - no <- isJust <$> lookupEnvNonEmpty "NO_CACHE_LOCALSTATEQUERY" - pure DebugConfig{ cacheLocalStateQueryTTL = if no then Nothing else mttl } + no <- isJust <$> lookupEnvNonEmpty "NO_CACHE_LISTPOOLS" + pure $ if no then NoCache else ttl -- | Directory for extra logging. Buildkite will set this environment variable -- and upload logs in it automatically. diff --git a/lib/shelley/src/Control/Cache.hs b/lib/shelley/src/Control/Cache.hs index 80c28aca87e..0cb1a8ea1c0 100644 --- a/lib/shelley/src/Control/Cache.hs +++ b/lib/shelley/src/Control/Cache.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE DeriveGeneric #-} -- | -- Copyright: © 2021 IOHK -- License: Apache-2.0 -- -- This module provides a utility for caching the results of long running actions. module Control.Cache - ( CacheWorker (..) + ( CacheConfig (..) + , CacheWorker (..) , MkCacheWorker , newCacheWorker , don'tCacheWorker @@ -21,6 +23,8 @@ import Control.Monad ( forever ) import Data.Time.Clock ( NominalDiffTime ) +import GHC.Generics + ( Generic ) import UnliftIO ( MonadIO ) import UnliftIO.Concurrent @@ -33,6 +37,15 @@ import UnliftIO.STM {------------------------------------------------------------------------------- Cache Worker -------------------------------------------------------------------------------} +-- | Caching behavior configuration. +data CacheConfig + = NoCache + -- ^ The value is not cached at all. + | CacheTTL NominalDiffTime + -- ^ The value is cached immediately + -- and re-requested after the time to live (TTL) has passed. + deriving (Eq, Ord, Show, Generic) + -- | A worker (an action of type @IO ()@) that -- runs a function periodically and caches the result. newtype CacheWorker = CacheWorker { runCacheWorker :: IO () } diff --git a/lib/shelley/test/integration/Main.hs b/lib/shelley/test/integration/Main.hs index 91fc6b32d45..37bb00c53c6 100644 --- a/lib/shelley/test/integration/Main.hs +++ b/lib/shelley/test/integration/Main.hs @@ -68,7 +68,7 @@ import Cardano.Wallet.Shelley.Launch.Cluster , clusterEraFromEnv , clusterEraToString , clusterToApiEra - , debugConfigFromEnv + , listPoolsConfigFromEnv , localClusterConfigFromEnv , moveInstantaneousRewardsTo , oneMillionAda @@ -331,7 +331,7 @@ specWithServer testDir (tr, tracers) = aroundAll withContext let db = testDir "wallets" createDirectory db listen <- walletListenFromEnv - debug <- debugConfigFromEnv + cacheListPools <- listPoolsConfigFromEnv let testMetadata = $(getTestData) "token-metadata.json" withMetadataServer (queryServerStatic testMetadata) $ \tokenMetaUrl -> serveWallet @@ -345,7 +345,7 @@ specWithServer testDir (tr, tracers) = aroundAll withContext Nothing Nothing (Just tokenMetaUrl) - (Just debug) + cacheListPools conn block0 (gp, vData)