diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index aebc5cf2c64..7e5178c3354 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/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 diff --git a/cardano-api/src/Cardano/Api/Utils.hs b/cardano-api/src/Cardano/Api/Utils.hs index b658e3e8602..b73c13483fb 100644 --- a/cardano-api/src/Cardano/Api/Utils.hs +++ b/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) diff --git a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs index ba8d25876fa..b85056d6566 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs +++ b/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 = diff --git a/cardano-cli/src/Cardano/CLI/Helpers.hs b/cardano-cli/src/Cardano/CLI/Helpers.hs index 0abb0965666..511b631989e 100644 --- a/cardano-cli/src/Cardano/CLI/Helpers.hs +++ b/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 diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index 7b24fa49f22..6d7b2cbc9fc 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/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 = diff --git a/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs b/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs index 1fe31815125..17641797241 100644 --- a/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs +++ b/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 diff --git a/cardano-submit-api/src/Cardano/TxSubmit/CLI/Parsers.hs b/cardano-submit-api/src/Cardano/TxSubmit/CLI/Parsers.hs index b32db5920db..37aa97bedcb 100644 --- a/cardano-submit-api/src/Cardano/TxSubmit/CLI/Parsers.hs +++ b/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