Add --cache-listpools-ttl command line argument

* Also add `--no-cache-listpools`
* Rename the environment variables to `CACHE_LISTPOOLS_TTL` and `NO_CACHE_LISTPOOLS`.

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)

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,22 +122,27 @@ 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
     , long
     , 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)

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)

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

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.

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 () }

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)