Move cacheListPoolsOption into cardano-cli

Add unit tests for TTL parsing
cardano-foundation · Sep 28, 2021 · 22da150 · 22da150
1 parent 99a2835
commit 22da150
Show file tree

Hide file tree

Showing 6 changed files with 48 additions and 22 deletions.
diff --git a/lib/cli/src/Cardano/CLI.hs b/lib/cli/src/Cardano/CLI.hs
@@ -45,6 +45,7 @@ module Cardano.CLI
     -- * Option & Argument Parsers
     , optionT
     , argumentT
+    , cacheListPoolsOption
     , databaseOption
     , hostPreferenceOption
     , listenOption
@@ -197,6 +198,8 @@ import Control.Applicative
     ( optional, some, (<|>) )
 import Control.Arrow
     ( first, left )
+import Control.Cache
+    ( CacheConfig (..) )
 import Control.Monad
     ( forM_, forever, join, unless, void, when )
 import Control.Monad.IO.Class
@@ -1142,7 +1145,7 @@ cmdNetworkClock mkClient =
         runClient wPort Aeson.encodePretty $ networkClock mkClient forceNtpCheck
 
 {-------------------------------------------------------------------------------
-                            Commands - 'launch'
+    Commands - 'serve'
 -------------------------------------------------------------------------------}
 
 -- | Initialize a directory to store data such as blocks or the wallet databases
@@ -1405,6 +1408,23 @@ walletIdArgument :: Parser WalletId
 walletIdArgument = argumentT $ mempty
     <> metavar "WALLET_ID"
 
+-- | [--no-cache-listpools|--cache-listpools-ttl DURATION]
+cacheListPoolsOption :: Parser CacheConfig
+cacheListPoolsOption = no <|> fmap (CacheTTL . getQuantity) ttl
+  where
+    ttl :: Parser (Quantity "second" NominalDiffTime)
+    ttl = fmap Quantity $ optionT $ mempty
+        <> long "cache-listpools-ttl"
+        <> metavar "TTL"
+        <> help ( "Cache time to live (TTL) for stake-pools listing. "
+            <> "Expressed in seconds with a trailing 's'. "
+            )
+        <> value 3600
+        <> showDefaultWith showT
+    no = flag' NoCache $ mempty
+        <> long "no-cache-listpools"
+        <> help "Do not cache the stake-pools listing."
+
 -- | [--stake=STAKE]
 stakeOption :: Parser (Maybe Coin)
 stakeOption = optional $ optionT $ mempty

diff --git a/lib/cli/test/unit/Cardano/CLISpec.hs b/lib/cli/test/unit/Cardano/CLISpec.hs
@@ -18,6 +18,7 @@ import Prelude
 import Cardano.CLI
     ( Port (..)
     , TxId
+    , cacheListPoolsOption
     , cli
     , cmdAddress
     , cmdKey
@@ -46,6 +47,10 @@ import Cardano.Wallet.Primitive.Types
     ( PoolMetadataSource )
 import Cardano.Wallet.Primitive.Types.Tx
     ( TxMetadata (..), TxMetadataValue (..) )
+import Control.Cache
+    ( CacheConfig (..) )
+import Control.Monad
+    ( forM_ )
 import Data.Proxy
     ( Proxy (..) )
 import Data.Quantity
@@ -271,15 +276,7 @@ spec = do
             , ("null 3", "{ }", ok (Just (ApiT mempty)))
             ]
 
-    describe "Tx TTL option" $ do
-        let parse arg = execParserPure defaultPrefs
-                (info timeToLiveOption mempty) ["--ttl", arg]
-        let ok ex (Success res) = Just (Quantity ex) == res
-            ok _ _ = False
-        let err (Failure _) = True
-            err _ = False
-        mapM_
-            (\(desc, arg, tst) -> it desc (parse arg `shouldSatisfy` tst))
+    let parseTimeTests =
             [ ("valid integer", "1s", ok 1)
             , ("valid zero", "0s", ok 0)
             , ("invalid negative", "-1s", err)
@@ -290,6 +287,25 @@ spec = do
             , ("malformed emptyish", "s", err)
             , ("malformed leading", "a1s", err)
             ]
+          where
+            ok ex (Success res) = Just (Quantity ex) == res
+            ok _ _ = False
+            err (Failure _) = True
+            err _ = False
+
+    describe "Tx TTL option" $ do
+        let parse arg = execParserPure defaultPrefs
+                (info timeToLiveOption mempty) ["--ttl", arg]
+        forM_ parseTimeTests $ \(desc, arg, tst) ->
+            it desc $ parse arg `shouldSatisfy` tst
+
+    describe "Cache listpools TTL option" $ do
+        let parse arg = execParserPure defaultPrefs
+                (info cacheListPoolsOption mempty) ["--cache-listpools-ttl", arg]
+        let toMaybe (CacheTTL x) = Just (Quantity x)
+            toMaybe (NoCache) = Nothing
+        forM_ parseTimeTests $ \(desc, arg, tst) ->
+            it desc $ parse arg `shouldSatisfy` (tst . fmap toMaybe)
 
   where
     backspace :: Text

diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal
@@ -213,6 +213,7 @@ library
       Cardano.Wallet.Util
       Cardano.Wallet.Version
       Cardano.Wallet.Version.TH
+      Control.Cache
       Control.Concurrent.Concierge
       Crypto.Hash.Utils
       Data.Function.Utils

diff --git a/lib/shelley/src/Control/Cache.hs → lib/core/src/Control/Cache.hs b/lib/shelley/src/Control/Cache.hs → lib/core/src/Control/Cache.hs
diff --git a/lib/shelley/cardano-wallet.cabal b/lib/shelley/cardano-wallet.cabal
@@ -105,7 +105,6 @@ library
       Cardano.Wallet.Shelley.Launch
       Cardano.Wallet.Shelley.Launch.Cluster
       Cardano.Wallet.Shelley.Pools
-      Control.Cache
 
 executable cardano-wallet
   default-language:

diff --git a/lib/shelley/exe/cardano-wallet.hs b/lib/shelley/exe/cardano-wallet.hs
@@ -34,6 +34,7 @@ import Cardano.BM.Trace
 import Cardano.CLI
     ( LogOutput (..)
     , LoggingOptions
+    , cacheListPoolsOption
     , cli
     , cmdAddress
     , cmdKey
@@ -204,17 +205,6 @@ 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