Check CLI argument bounds

Author: newhoggy

cardano-api/src/Cardano/Api.hs

@@ -751,6 +751,9 @@ module Cardano.Api (
     txInsExistInUTxO,
     notScriptLockedTxIns,
     textShow,
+
+    -- ** CLI option parsing
+    bounded,
   ) where
 
 import           Cardano.Api.Address

cardano-api/src/Cardano/Api/Utils.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 #if !defined(mingw32_HOST_OS)
 #define UNIX
@@ -22,10 +25,13 @@ module Cardano.Api.Utils
   , runParsecParser
   , textShow
   , writeSecrets
+
+    -- ** CLI option parsing
+  , bounded
   ) where
 
 import           Control.Exception (bracket)
-import           Control.Monad (forM_)
+import           Control.Monad (forM_, when)
 import qualified Data.Aeson.Types as Aeson
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Builder as Builder
@@ -48,6 +54,9 @@ import           System.Directory (emptyPermissions, readable, setPermissions)
 #endif
 
 import           Cardano.Api.Eras
+import           Options.Applicative (ReadM)
+import           Options.Applicative.Builder (eitherReader)
+import qualified Text.Read as Read
 
 (?!) :: Maybe a -> e -> Either e a
 Nothing ?! e = Left e
@@ -131,3 +140,10 @@ renderEra (AnyCardanoEra AllegraEra) = "Allegra"
 renderEra (AnyCardanoEra MaryEra)    = "Mary"
 renderEra (AnyCardanoEra AlonzoEra)  = "Alonzo"
 renderEra (AnyCardanoEra BabbageEra) = "Babbage"
+
+bounded :: forall a. (Bounded a, Integral a, Show a) => String -> ReadM a
+bounded t = eitherReader $ \s -> do
+  i <- Read.readEither @Integer s
+  when (i < fromIntegral (minBound @a)) $ Left $ t <> " must not be less than " <> show (minBound @a)
+  when (i > fromIntegral (maxBound @a)) $ Left $ t <> " must not greater than " <> show (maxBound @a)
+  pure (fromIntegral i)

cardano-cli/src/Cardano/CLI/Byron/Parsers.hs

@@ -664,12 +664,11 @@ pNetworkId =
 
 pTestnetMagic :: Parser NetworkMagic
 pTestnetMagic =
-  NetworkMagic <$>
-    Opt.option Opt.auto
-      (  Opt.long "testnet-magic"
-      <> Opt.metavar "NATURAL"
-      <> Opt.help "Specify a testnet magic id."
-      )
+  fmap NetworkMagic $ Opt.option (bounded "TESTNET_MAGIC") $ mconcat
+    [ Opt.long "testnet-magic"
+    , Opt.metavar "NATURAL"
+    , Opt.help "Specify a testnet magic id."
+    ]
 
 parseNewSigningKeyFile :: String -> Parser NewSigningKeyFile
 parseNewSigningKeyFile opt =

cardano-cli/src/Cardano/CLI/Helpers.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Cardano.CLI.Helpers
   ( HelpersError(..)
@@ -19,12 +20,22 @@ import           Cardano.Prelude (ConvertText (..))
 import           Codec.CBOR.Pretty (prettyHexEnc)
 import           Codec.CBOR.Read (DeserialiseFailure, deserialiseFromBytes)
 import           Codec.CBOR.Term (decodeTerm, encodeTerm)
+import           Control.Exception (Exception (..), IOException)
+import           Control.Monad (unless, when)
+import           Control.Monad.IO.Class (MonadIO (..))
+import           Control.Monad.Trans.Except (ExceptT)
 import           Control.Monad.Trans.Except.Extra (handleIOExceptT, left)
+import           Data.Bifunctor (Bifunctor (..))
+import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LB
+import           Data.Functor (void)
+import           Data.Text (Text)
 import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
 import qualified System.Console.ANSI as ANSI
 import           System.Console.ANSI
+import qualified System.Directory as IO
 import qualified System.IO as IO
 
 import           Cardano.Binary (Decoder, fromCBOR)
@@ -34,17 +45,6 @@ import qualified Cardano.Chain.Update as Update
 import qualified Cardano.Chain.UTxO as UTxO
 import           Cardano.CLI.Types
 
-import           Control.Exception (Exception (..), IOException)
-import           Control.Monad (unless, when)
-import           Control.Monad.IO.Class (MonadIO (..))
-import           Control.Monad.Trans.Except (ExceptT)
-import           Data.Bifunctor (Bifunctor (..))
-import           Data.ByteString (ByteString)
-import           Data.Functor (void)
-import           Data.Text (Text)
-import qualified Data.Text.IO as Text
-import qualified System.Directory as IO
-
 data HelpersError
   = CBORPrettyPrintError !DeserialiseFailure
   | CBORDecodingError !DeserialiseFailure

cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs

@@ -1730,31 +1730,28 @@ pSigningKeyFile fdir =
 
 pKesPeriod :: Parser KESPeriod
 pKesPeriod =
-  KESPeriod <$>
-    Opt.option Opt.auto
-      (  Opt.long "kes-period"
-      <> Opt.metavar "NATURAL"
-      <> Opt.help "The start of the KES key validity period."
-      )
+  fmap KESPeriod $ Opt.option (bounded "KES_PERIOD") $ mconcat
+    [ Opt.long "kes-period"
+    , Opt.metavar "NATURAL"
+    , Opt.help "The start of the KES key validity period."
+    ]
 
 pEpochNo :: Parser EpochNo
 pEpochNo =
-  EpochNo <$>
-    Opt.option Opt.auto
-      (  Opt.long "epoch"
-      <> Opt.metavar "NATURAL"
-      <> Opt.help "The epoch number."
-      )
+  fmap EpochNo $ Opt.option (bounded "EPOCH") $ mconcat
+    [ Opt.long "epoch"
+    , Opt.metavar "NATURAL"
+    , Opt.help "The epoch number."
+    ]
 
 
 pEpochNoUpdateProp :: Parser EpochNo
 pEpochNoUpdateProp =
-  EpochNo <$>
-    Opt.option Opt.auto
-      (  Opt.long "epoch"
-      <> Opt.metavar "NATURAL"
-      <> Opt.help "The epoch number in which the update proposal is valid."
-      )
+  fmap EpochNo $ Opt.option (bounded "EPOCH") $ mconcat
+    [ Opt.long "epoch"
+    , Opt.metavar "EPOCH"
+    , Opt.help "The epoch number in which the update proposal is valid."
+    ]
 
 pGenesisFile :: String -> Parser GenesisFile
 pGenesisFile desc =
@@ -2054,12 +2051,11 @@ pNetworkId =
 
 pTestnetMagic :: Parser NetworkMagic
 pTestnetMagic =
-  NetworkMagic <$>
-    Opt.option Opt.auto
-      (  Opt.long "testnet-magic"
-      <> Opt.metavar "NATURAL"
-      <> Opt.help "Specify a testnet magic id."
-      )
+  fmap NetworkMagic $ Opt.option (bounded "TESTNET_MAGIC") $ mconcat
+    [ Opt.long "testnet-magic"
+    , Opt.metavar "TESTNET_MAGIC"
+    , Opt.help "Specify a testnet magic id."
+    ]
 
 pTxSubmitFile :: Parser FilePath
 pTxSubmitFile =
@@ -2367,12 +2363,12 @@ pPolicyId =
 
 pInvalidBefore :: Parser SlotNo
 pInvalidBefore = fmap SlotNo $ asum
-  [ Opt.option Opt.auto $ mconcat
+  [ Opt.option (bounded "SLOT") $ mconcat
     [ Opt.long "invalid-before"
     , Opt.metavar "SLOT"
     , Opt.help "Time that transaction is valid from (in slots)."
     ]
-  , Opt.option Opt.auto $ mconcat
+  , Opt.option (bounded "SLOT") $ mconcat
     [ Opt.long "lower-bound"
     , Opt.metavar "SLOT"
     , Opt.help $ mconcat
@@ -2386,12 +2382,12 @@ pInvalidBefore = fmap SlotNo $ asum
 pInvalidHereafter :: Parser SlotNo
 pInvalidHereafter =
   fmap SlotNo $ asum
-  [ Opt.option Opt.auto $ mconcat
+  [ Opt.option (bounded "SLOT") $ mconcat
     [ Opt.long "invalid-hereafter"
     , Opt.metavar "SLOT"
     , Opt.help "Time that transaction is valid until (in slots)."
     ]
-  , Opt.option Opt.auto $ mconcat
+  , Opt.option (bounded "SLOT") $ mconcat
     [ Opt.long "upper-bound"
     , Opt.metavar "SLOT"
     , Opt.help $ mconcat
@@ -2400,7 +2396,7 @@ pInvalidHereafter =
       ]
     , Opt.internal
     ]
-  , Opt.option Opt.auto $ mconcat
+  , Opt.option (bounded "SLOT") $ mconcat
     [ Opt.long "ttl"
     , Opt.metavar "SLOT"
     , Opt.help "Time to live (in slots) (deprecated; use --invalid-hereafter instead)."
@@ -3051,12 +3047,11 @@ pPoolDeposit =
 
 pEpochBoundRetirement :: Parser EpochNo
 pEpochBoundRetirement =
-    EpochNo <$>
-    Opt.option Opt.auto
-      (  Opt.long "pool-retirement-epoch-boundary"
-      <> Opt.metavar "INT"
-      <> Opt.help "Epoch bound on pool retirement."
-      )
+  fmap EpochNo $ Opt.option (bounded "EPOCH_BOUNDARY") $ mconcat
+    [ Opt.long "pool-retirement-epoch-boundary"
+    , Opt.metavar "EPOCH_BOUNDARY"
+    , Opt.help "Epoch bound on pool retirement."
+    ]
 
 pNumberOfPools :: Parser Natural
 pNumberOfPools =
@@ -3248,14 +3243,13 @@ defaultByronEpochSlots = 21600
 
 pEpochSlots :: Parser EpochSlots
 pEpochSlots =
-  EpochSlots <$>
-    Opt.option Opt.auto
-      (  Opt.long "epoch-slots"
-      <> Opt.metavar "NATURAL"
-      <> Opt.help "The number of slots per epoch for the Byron era."
-      <> Opt.value defaultByronEpochSlots -- Default to the mainnet value.
-      <> Opt.showDefault
-      )
+  fmap EpochSlots $ Opt.option (bounded "SLOTS") $ mconcat
+    [ Opt.long "epoch-slots"
+    , Opt.metavar "SLOTS"
+    , Opt.help "The number of slots per epoch for the Byron era."
+    , Opt.value defaultByronEpochSlots -- Default to the mainnet value.
+    , Opt.showDefault
+    ]
 
 pProtocolVersion :: Parser (Natural, Natural)
 pProtocolVersion =

cardano-node/src/Cardano/Node/Handlers/Shutdown.hs

@@ -26,12 +26,12 @@ module Cardano.Node.Handlers.Shutdown
   )
 where
 
-import           Control.Applicative (Alternative (..))
 import           Control.Concurrent.Async (race_)
 import           Control.Exception (try)
 import           Control.Exception.Base (throwIO)
 import           Control.Monad (void, when)
 import           Data.Aeson (FromJSON, ToJSON)
+import           Data.Foldable (asum)
 import           Data.Text (Text, pack)
 import           Generic.Data.Orphans ()
 import           GHC.Generics (Generic)
@@ -42,6 +42,7 @@ import qualified System.IO as IO
 import qualified System.IO.Error as IO
 import           System.Posix.Types (Fd (Fd))
 
+import           Cardano.Api (bounded)
 import           Cardano.Slotting.Slot (WithOrigin (..))
 import           "contra-tracer" Control.Tracer
 import           Ouroboros.Consensus.Block (Header)
@@ -50,7 +51,6 @@ import           Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
 import           Ouroboros.Consensus.Util.STM (Watcher (..), forkLinkedWatcher)
 import           Ouroboros.Network.Block (BlockNo (..), HasHeader, SlotNo (..), pointSlot)
 
-
 data ShutdownOn
   = ASlot  !SlotNo
   | ABlock !BlockNo
@@ -61,21 +61,21 @@ deriving instance FromJSON ShutdownOn
 deriving instance ToJSON ShutdownOn
 
 parseShutdownOn :: Opt.Parser ShutdownOn
-parseShutdownOn =
-    Opt.option (ASlot . SlotNo <$> Opt.auto) (
-         Opt.long "shutdown-on-slot-synced"
-      <> Opt.metavar "SLOT"
-      <> Opt.help "Shut down the process after ChainDB is synced up to the specified slot"
-      <> Opt.hidden
-    )
-    <|>
-    Opt.option (ABlock . BlockNo <$> Opt.auto) (
-         Opt.long "shutdown-on-block-synced"
-      <> Opt.metavar "BLOCK"
-      <> Opt.help "Shut down the process after ChainDB is synced up to the specified block"
-      <> Opt.hidden
-    )
-    <|> pure NoShutdown
+parseShutdownOn = asum
+  [ Opt.option (ASlot . SlotNo <$> bounded "SLOT") $ mconcat
+    [ Opt.long "shutdown-on-slot-synced"
+    , Opt.metavar "SLOT"
+    , Opt.help "Shut down the process after ChainDB is synced up to the specified slot"
+    , Opt.hidden
+    ]
+  , Opt.option (ABlock . BlockNo <$> bounded "BLOCK") $ mconcat
+    [ Opt.long "shutdown-on-block-synced"
+    , Opt.metavar "BLOCK"
+    , Opt.help "Shut down the process after ChainDB is synced up to the specified block"
+    , Opt.hidden
+    ]
+  , pure NoShutdown
+  ]
 
 data ShutdownTrace
   = ShutdownRequested

cardano-submit-api/src/Cardano/TxSubmit/CLI/Parsers.hs

@@ -10,9 +10,11 @@ module Cardano.TxSubmit.CLI.Parsers
   ) where
 
 import           Cardano.Api (AnyConsensusModeParams (..), ConsensusModeParams (..),
-                   EpochSlots (..), NetworkId (..), NetworkMagic (..), SocketPath (..))
+                   EpochSlots (..), NetworkId (..), NetworkMagic (..), SocketPath (..), bounded)
+
 import           Cardano.TxSubmit.CLI.Types (ConfigFile (..), TxSubmitNodeParams (..))
 import           Cardano.TxSubmit.Rest.Parsers (pWebserverConfig)
+
 import           Control.Applicative (Alternative (..), (<**>))
 import           Data.Word (Word64)
 import           Options.Applicative (Parser, ParserInfo)
@@ -56,11 +58,12 @@ pNetworkId = pMainnet <|> fmap Testnet pTestnetMagic
       )
 
     pTestnetMagic :: Parser NetworkMagic
-    pTestnetMagic = NetworkMagic <$> Opt.option Opt.auto
-      (   Opt.long "testnet-magic"
-      <>  Opt.metavar "NATURAL"
-      <>  Opt.help "Specify a testnet magic id."
-      )
+    pTestnetMagic =
+      fmap NetworkMagic $ Opt.option (bounded "TESTNET_MAGIC") $ mconcat
+        [ Opt.long "testnet-magic"
+        , Opt.metavar "TESTNET_MAGIC"
+        , Opt.help "Specify a testnet magic id."
+        ]
 
 
 -- TODO: This was ripped from `cardano-cli` because, unfortunately, it's not