{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Chairman.Commands.Run
  ( cmdRun
  ) where

import           Cardano.Api
import           Cardano.Api.Protocol.Byron
import           Cardano.Api.Protocol.Cardano
import           Cardano.Api.Protocol.Shelley
import           Cardano.Chairman (chairmanTest)
import           Cardano.Node.Configuration.POM (parseNodeConfigurationFP, pncProtocol)
import           Cardano.Node.Protocol.Types (Protocol (..))
import           Cardano.Node.Types
import           Cardano.Prelude hiding (option)
import           Control.Monad.Class.MonadTime (DiffTime)
import           Control.Tracer (Tracer (..), stdoutTracer)
import           Options.Applicative
import           Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..))

import qualified Data.Time.Clock as DTC
import qualified Options.Applicative as Opt
import qualified System.IO as IO

--TODO: replace this with the new stuff from Cardano.Api.Protocol
mkNodeClientProtocol :: Protocol -> SomeNodeClientProtocol
mkNodeClientProtocol :: Protocol -> SomeNodeClientProtocol
mkNodeClientProtocol Protocol
protocol =
  case Protocol
protocol of
    Protocol
ByronProtocol ->
      EpochSlots -> SomeNodeClientProtocol
mkSomeNodeClientProtocolByron
        (Word64 -> EpochSlots
EpochSlots Word64
21600)

    Protocol
ShelleyProtocol ->
      SomeNodeClientProtocol
mkSomeNodeClientProtocolShelley

    Protocol
CardanoProtocol ->
      EpochSlots -> SomeNodeClientProtocol
mkSomeNodeClientProtocolCardano
        (Word64 -> EpochSlots
EpochSlots Word64
21600)

data RunOpts = RunOpts
  { -- | Stop the test after given number of seconds. The chairman will
    -- observe only for the given period of time, and check the consensus
    -- and progress conditions at the end.
    --
    RunOpts -> DiffTime
caRunningTime :: !DiffTime
    -- | Expect this amount of progress (chain growth) by the end of the test.
  , RunOpts -> BlockNo
caMinProgress :: !BlockNo
  , RunOpts -> [SocketPath]
caSocketPaths :: ![SocketPath]
  , RunOpts -> ConfigYamlFilePath
caConfigYaml :: !ConfigYamlFilePath
  , RunOpts -> SecurityParam
caSecurityParam :: !SecurityParam
  , RunOpts -> NetworkMagic
caNetworkMagic :: !NetworkMagic
  }

parseConfigFile :: Parser FilePath
parseConfigFile :: Parser FilePath
parseConfigFile =
  Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
    ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"config"
    Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NODE-CONFIGURATION"
    Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Configuration file for the cardano-node"
    Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Completer -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer (FilePath -> Completer
bashCompleter FilePath
"file")
    )

parseSocketPath :: Text -> Parser SocketPath
parseSocketPath :: Text -> Parser SocketPath
parseSocketPath Text
helpMessage =
  FilePath -> SocketPath
SocketPath (FilePath -> SocketPath) -> Parser FilePath -> Parser SocketPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields FilePath -> Parser FilePath
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
    ( FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"socket-path"
    Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help (Text -> FilePath
forall a b. ConvertText a b => a -> b
toS Text
helpMessage)
    Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Completer -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer (FilePath -> Completer
bashCompleter FilePath
"file")
    Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"FILEPATH"
    )

parseRunningTime :: Parser DiffTime
parseRunningTime :: Parser DiffTime
parseRunningTime =
  ReadM DiffTime -> Mod OptionFields DiffTime -> Parser DiffTime
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> DiffTime) (Int -> DiffTime) -> ReadM Int -> ReadM DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Int
forall a. Read a => ReadM a
auto)
    (  FilePath -> Mod OptionFields DiffTime
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"timeout"
    Mod OptionFields DiffTime
-> Mod OptionFields DiffTime -> Mod OptionFields DiffTime
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields DiffTime
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
't'
    Mod OptionFields DiffTime
-> Mod OptionFields DiffTime -> Mod OptionFields DiffTime
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields DiffTime
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"SECONDS"
    Mod OptionFields DiffTime
-> Mod OptionFields DiffTime -> Mod OptionFields DiffTime
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields DiffTime
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Run the chairman for this length of time in seconds."
    )

parseSecurityParam :: Parser SecurityParam
parseSecurityParam :: Parser SecurityParam
parseSecurityParam =
  ReadM SecurityParam
-> Mod OptionFields SecurityParam -> Parser SecurityParam
forall a. ReadM a -> Mod OptionFields a -> Parser a
option (Word64 -> SecurityParam
SecurityParam (Word64 -> SecurityParam) -> ReadM Word64 -> ReadM SecurityParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Word64
forall a. Read a => ReadM a
Opt.auto)
    ( FilePath -> Mod OptionFields SecurityParam
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"security-parameter"
    Mod OptionFields SecurityParam
-> Mod OptionFields SecurityParam -> Mod OptionFields SecurityParam
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields SecurityParam
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"INT"
    Mod OptionFields SecurityParam
-> Mod OptionFields SecurityParam -> Mod OptionFields SecurityParam
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields SecurityParam
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Security parameter"
    )


parseTestnetMagic :: Parser NetworkMagic
parseTestnetMagic :: Parser NetworkMagic
parseTestnetMagic =
  Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkMagic) -> Parser Word32 -> Parser NetworkMagic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ReadM Word32 -> Mod OptionFields Word32 -> Parser Word32
forall a. ReadM a -> Mod OptionFields a -> Parser a
Opt.option ReadM Word32
forall a. Read a => ReadM a
Opt.auto
      (  FilePath -> Mod OptionFields Word32
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
Opt.long FilePath
"testnet-magic"
      Mod OptionFields Word32
-> Mod OptionFields Word32 -> Mod OptionFields Word32
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Word32
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
Opt.metavar FilePath
"INT"
      Mod OptionFields Word32
-> Mod OptionFields Word32 -> Mod OptionFields Word32
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Word32
forall (f :: * -> *) a. FilePath -> Mod f a
Opt.help FilePath
"The testnet network magic number"
      )

parseProgress :: Parser BlockNo
parseProgress :: Parser BlockNo
parseProgress =
  ReadM BlockNo -> Mod OptionFields BlockNo -> Parser BlockNo
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((Int -> BlockNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> BlockNo) (Int -> BlockNo) -> ReadM Int -> ReadM BlockNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Int
forall a. Read a => ReadM a
auto)
    (  FilePath -> Mod OptionFields BlockNo
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"require-progress"
    Mod OptionFields BlockNo
-> Mod OptionFields BlockNo -> Mod OptionFields BlockNo
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields BlockNo
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'p'
    Mod OptionFields BlockNo
-> Mod OptionFields BlockNo -> Mod OptionFields BlockNo
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields BlockNo
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"INT"
    Mod OptionFields BlockNo
-> Mod OptionFields BlockNo -> Mod OptionFields BlockNo
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields BlockNo
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Require this much chain-growth progress, in blocks."
  )

parseRunOpts :: Parser RunOpts
parseRunOpts :: Parser RunOpts
parseRunOpts =
  DiffTime
-> BlockNo
-> [SocketPath]
-> ConfigYamlFilePath
-> SecurityParam
-> NetworkMagic
-> RunOpts
RunOpts
  (DiffTime
 -> BlockNo
 -> [SocketPath]
 -> ConfigYamlFilePath
 -> SecurityParam
 -> NetworkMagic
 -> RunOpts)
-> Parser DiffTime
-> Parser
     (BlockNo
      -> [SocketPath]
      -> ConfigYamlFilePath
      -> SecurityParam
      -> NetworkMagic
      -> RunOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser DiffTime
parseRunningTime
  Parser
  (BlockNo
   -> [SocketPath]
   -> ConfigYamlFilePath
   -> SecurityParam
   -> NetworkMagic
   -> RunOpts)
-> Parser BlockNo
-> Parser
     ([SocketPath]
      -> ConfigYamlFilePath -> SecurityParam -> NetworkMagic -> RunOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser BlockNo
parseProgress
  Parser
  ([SocketPath]
   -> ConfigYamlFilePath -> SecurityParam -> NetworkMagic -> RunOpts)
-> Parser [SocketPath]
-> Parser
     (ConfigYamlFilePath -> SecurityParam -> NetworkMagic -> RunOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser SocketPath -> Parser [SocketPath]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Text -> Parser SocketPath
parseSocketPath Text
"Path to a cardano-node socket")
  Parser
  (ConfigYamlFilePath -> SecurityParam -> NetworkMagic -> RunOpts)
-> Parser ConfigYamlFilePath
-> Parser (SecurityParam -> NetworkMagic -> RunOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> ConfigYamlFilePath)
-> Parser FilePath -> Parser ConfigYamlFilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> ConfigYamlFilePath
ConfigYamlFilePath Parser FilePath
parseConfigFile
  Parser (SecurityParam -> NetworkMagic -> RunOpts)
-> Parser SecurityParam -> Parser (NetworkMagic -> RunOpts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser SecurityParam
parseSecurityParam
  Parser (NetworkMagic -> RunOpts)
-> Parser NetworkMagic -> Parser RunOpts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser NetworkMagic
parseTestnetMagic

run :: RunOpts -> IO ()
run :: RunOpts -> IO ()
run RunOpts
    { DiffTime
caRunningTime :: DiffTime
caRunningTime :: RunOpts -> DiffTime
caRunningTime
    , BlockNo
caMinProgress :: BlockNo
caMinProgress :: RunOpts -> BlockNo
caMinProgress
    , [SocketPath]
caSocketPaths :: [SocketPath]
caSocketPaths :: RunOpts -> [SocketPath]
caSocketPaths
    , ConfigYamlFilePath
caConfigYaml :: ConfigYamlFilePath
caConfigYaml :: RunOpts -> ConfigYamlFilePath
caConfigYaml
    , SecurityParam
caSecurityParam :: SecurityParam
caSecurityParam :: RunOpts -> SecurityParam
caSecurityParam
    , NetworkMagic
caNetworkMagic :: NetworkMagic
caNetworkMagic :: RunOpts -> NetworkMagic
caNetworkMagic
    } = do

  PartialNodeConfiguration
partialNc <- IO PartialNodeConfiguration -> IO PartialNodeConfiguration
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PartialNodeConfiguration -> IO PartialNodeConfiguration)
-> (Maybe ConfigYamlFilePath -> IO PartialNodeConfiguration)
-> Maybe ConfigYamlFilePath
-> IO PartialNodeConfiguration
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Maybe ConfigYamlFilePath -> IO PartialNodeConfiguration
parseNodeConfigurationFP (Maybe ConfigYamlFilePath -> IO PartialNodeConfiguration)
-> Maybe ConfigYamlFilePath -> IO PartialNodeConfiguration
forall a b. (a -> b) -> a -> b
$ ConfigYamlFilePath -> Maybe ConfigYamlFilePath
forall a. a -> Maybe a
Just ConfigYamlFilePath
caConfigYaml

  Protocol
ptcl <- case PartialNodeConfiguration -> Either Text Protocol
pncProtocol PartialNodeConfiguration
partialNc of
            Left Text
err -> Text -> IO Protocol
forall a. HasCallStack => Text -> a
panic (Text -> IO Protocol) -> Text -> IO Protocol
forall a b. (a -> b) -> a -> b
$ Text
"Chairman error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
            Right Protocol
protocol -> Protocol -> IO Protocol
forall (m :: * -> *) a. Monad m => a -> m a
return Protocol
protocol

  let someNodeClientProtocol :: SomeNodeClientProtocol
someNodeClientProtocol = Protocol -> SomeNodeClientProtocol
mkNodeClientProtocol Protocol
ptcl

  Tracer IO FilePath
-> SomeNodeClientProtocol
-> NetworkMagic
-> SecurityParam
-> DiffTime
-> BlockNo
-> [SocketPath]
-> IO ()
chairmanTest
    (Tracer IO FilePath -> Tracer IO FilePath
forall a. Tracer IO a -> Tracer IO a
timed Tracer IO FilePath
forall (m :: * -> *). MonadIO m => Tracer m FilePath
stdoutTracer)
    SomeNodeClientProtocol
someNodeClientProtocol
    NetworkMagic
caNetworkMagic
    SecurityParam
caSecurityParam
    DiffTime
caRunningTime
    BlockNo
caMinProgress
    [SocketPath]
caSocketPaths

  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

timed :: Tracer IO a -> Tracer IO a
timed :: Tracer IO a -> Tracer IO a
timed (Tracer a -> IO ()
runTracer) = (a -> IO ()) -> Tracer IO a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> IO ()) -> Tracer IO a) -> (a -> IO ()) -> Tracer IO a
forall a b. (a -> b) -> a -> b
$ \a
a -> do
  UTCTime
ts <- IO UTCTime
DTC.getCurrentTime
  FilePath -> IO ()
IO.putStr (FilePath
"[" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> UTCTime -> FilePath
forall a b. (Show a, ConvertText FilePath b) => a -> b
show UTCTime
ts FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"] ")
  a -> IO ()
runTracer a
a

cmdRun :: Mod CommandFields (IO ())
cmdRun :: Mod CommandFields (IO ())
cmdRun = FilePath -> ParserInfo (IO ()) -> Mod CommandFields (IO ())
forall a. FilePath -> ParserInfo a -> Mod CommandFields a
command FilePath
"run"  (ParserInfo (IO ()) -> Mod CommandFields (IO ()))
-> ParserInfo (IO ()) -> Mod CommandFields (IO ())
forall a b. (a -> b) -> a -> b
$ (Parser (IO ()) -> InfoMod (IO ()) -> ParserInfo (IO ()))
-> InfoMod (IO ()) -> Parser (IO ()) -> ParserInfo (IO ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parser (IO ()) -> InfoMod (IO ()) -> ParserInfo (IO ())
forall a. Parser a -> InfoMod a -> ParserInfo a
info InfoMod (IO ())
forall m. Monoid m => m
idm (Parser (IO ()) -> ParserInfo (IO ()))
-> Parser (IO ()) -> ParserInfo (IO ())
forall a b. (a -> b) -> a -> b
$ RunOpts -> IO ()
run (RunOpts -> IO ()) -> Parser RunOpts -> Parser (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser RunOpts
parseRunOpts