Fix options parse error code (#15)

# Description

Closes #13

`BadUsage` is used in `parseOptions` to produce the correct exit code on
parse failure.

Added documentation to `ExitStatus` and `StatusFlag`. These types now
live in the own `ExitCodes` module.

---------

Co-authored-by: Sandy Maguire <sandy@sandymaguire.me>

Author: ninioArtillero

ouroboros-consensus-diffusion/app/conformance-test-runner/ExitCodes.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Custom exit codes to implement the shrinking logic externally.
+module ExitCodes (ExitStatus (.., Success), StatusFlag (..), exitWithStatus) where
+
+import Data.Bits (Ior (..))
+import Data.Set (Set)
+import System.Exit (ExitCode (..), exitWith)
+
+-- | Exit statuses for the test runner. 'Success' is represented
+-- by an empty set of 'StatusFlags'.
+data ExitStatus = InternalError | BadUsage | Flags (Set StatusFlag)
+
+pattern Success :: ExitStatus
+pattern Success <- Flags (null -> True)
+  where
+    Success = Flags mempty
+
+-- | A 'ContinueShrinking' flag is returned whenever the 'TestFailed' or got
+-- 'Success' with a non-empty shrink index as input, unless no more shrinking
+-- on the input is possible. It is intended to signal the user to manually
+-- /pump/ the shrinker.
+data StatusFlag = TestFailed | ContinueShrinking deriving (Eq, Ord)
+
+exitWithStatus :: ExitStatus -> IO a
+exitWithStatus = exitWith . \case
+  Success -> ExitSuccess
+  InternalError -> ExitFailure 1
+  BadUsage -> ExitFailure 2
+  -- Flags are combined using bit-wise OR.
+  Flags flags -> ExitFailure $ getIor $ foldMap flagToCode flags
+ where
+  flagToCode :: StatusFlag -> Ior Int
+  flagToCode = Ior . \case
+    TestFailed -> 4
+    ContinueShrinking -> 8

ouroboros-consensus-diffusion/app/conformance-test-runner/Main.hs

@@ -1,24 +1,14 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-
 module Main (main) where
 
 import Data.Aeson (encode, throwDecode)
-import Data.Bits (Ior (..))
 import qualified Data.ByteString.Lazy.Char8 as BSL8
 import Data.Coerce
 import Data.Foldable
 import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Set (Set)
 import Data.Traversable
 import qualified Network.Socket as Socket
-import Options
-  ( Options (..)
-  , execParser
-  , options
-  )
+import Options (Options (..), parseOptions)
 import Ouroboros.Consensus.Util.IOLike
 import Ouroboros.Network.Diffusion.Topology
   ( LocalRootPeersGroup (..)
@@ -32,31 +22,10 @@ import Ouroboros.Network.PeerSelection (PeerAdvertise (..), PortNumber)
 import Ouroboros.Network.PeerSelection.LedgerPeers (RelayAccessPoint (..), UseLedgerPeers (..))
 import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..))
 import Server (run)
-import System.Exit (ExitCode (..))
+import System.Environment (getArgs)
 import Test.Consensus.PointSchedule (PointSchedule (..))
 import Test.Consensus.PointSchedule.Peers (PeerId (..), Peers (Peers), getPeerIds)
 
-data ExitStatus = InternalError | BadUsage | Flags (Set StatusFlag)
-
-pattern Success :: ExitStatus
-pattern Success <- Flags (null -> True)
-  where
-    Success = Flags mempty
-
-data StatusFlag = TestFailed | ContinueShrinking deriving (Eq, Ord)
-
-exitStatusToCode :: ExitStatus -> ExitCode
-exitStatusToCode = \case
-  Success -> ExitSuccess
-  InternalError -> ExitFailure 1
-  BadUsage -> ExitFailure 2
-  Flags flags -> ExitFailure $ getIor $ foldMap flagToCode flags
- where
-  flagToCode :: StatusFlag -> Ior Int
-  flagToCode = \case
-    TestFailed -> Ior 4
-    ContinueShrinking -> Ior 8
-
 testPointSchedule :: PointSchedule blk
 testPointSchedule =
   PointSchedule
@@ -101,7 +70,8 @@ makeTopology ports =
 
 main :: IO ()
 main = do
-  opts <- execParser options
+  args <- getArgs
+  opts <- parseOptions args
   contents <- BSL8.readFile (optTestFile opts)
   pointSchedule <- throwDecode contents :: IO (PointSchedule Bool)
   let simPeerMap = buildPeerMap (optPort opts) pointSchedule

ouroboros-consensus-diffusion/app/conformance-test-runner/Options.hs

@@ -2,10 +2,36 @@
 {-# LANGUAGE RecordWildCards #-}
 
 -- | Command line argument parser for the test runner.
-module Options (execParser, options, Options (..)) where
+module Options (parseOptions, Options (..)) where
 
+import ExitCodes
 import Options.Applicative
+  ( CompletionResult (execCompletion)
+  , Parser
+  , ParserInfo
+  , ParserResult (CompletionInvoked, Failure)
+  , auto
+  , defaultPrefs
+  , execParserPure
+  , fullDesc
+  , header
+  , help
+  , helper
+  , info
+  , long
+  , metavar
+  , option
+  , progDesc
+  , renderFailure
+  , short
+  , strArgument
+  , strOption
+  , value
+  , (<**>)
+  )
+import qualified Options.Applicative as O
 import Ouroboros.Network.PeerSelection (PortNumber)
+import System.IO (hPutStrLn, stderr)
 
 data Options = Options
   { optTestFile :: FilePath
@@ -31,7 +57,7 @@ options =
 
 optsP :: Parser Options
 optsP = do
-  optTestFile <- argument auto (metavar "TEST_FILE")
+  optTestFile <- strArgument $ metavar "TEST_FILE"
   optOutputTopologyFile <-
     strOption
       ( mconcat
@@ -54,3 +80,17 @@ optsP = do
           ]
       )
   pure Options{..}
+
+parseOptions :: [String] -> IO (Options)
+parseOptions args =
+  case execParserPure defaultPrefs options args of
+    O.Success opts -> pure opts
+    Failure failure -> do
+      let (msg, _) = renderFailure failure "conformance-test-runner"
+      hPutStrLn stderr msg
+      exitWithStatus BadUsage
+    CompletionInvoked compl -> do
+      -- Completion handler
+      msg <- execCompletion compl "conformance-test-runner"
+      putStr msg
+      exitWithStatus Success

ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal

@@ -334,6 +334,7 @@ executable conformance-test-runner
   hs-source-dirs: app/conformance-test-runner
   main-is: Main.hs
   other-modules:
+    ExitCodes
     Options
     Server
     MiniProtocols