{-# LANGUAGE DuplicateRecordFields #-}

module CardanoNode where

import Hydra.Prelude

import Cardano.Slotting.Time (diffRelativeTime, getRelativeTime, toRelativeTime)
import CardanoClient (QueryPoint (QueryTip), RunningNode (..), queryEraHistory, queryGenesisParameters, querySystemStart, queryTipSlotNo)
import Control.Lens ((?~), (^?!))
import Control.Tracer (Tracer, traceWith)
import Data.Aeson (Value (String), (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (atKey, key, _Number)
import Data.Fixed (Centi)
import Data.Text qualified as Text
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Hydra.Cardano.Api (
  AsType (AsPaymentKey),
  File (..),
  GenesisParameters (..),
  NetworkId,
  NetworkMagic (..),
  PaymentKey,
  SigningKey,
  SocketPath,
  VerificationKey,
  generateSigningKey,
  getProgress,
  getVerificationKey,
 )
import Hydra.Cardano.Api qualified as Api
import Hydra.Cluster.Fixture (KnownNetwork (..), toNetworkId)
import Hydra.Cluster.Util (readConfigFile)
import Network.HTTP.Simple (getResponseBody, httpBS, parseRequestThrow)
import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)
import System.Exit (ExitCode (..))
import System.FilePath (takeDirectory, (</>))
import System.Posix (ownerReadMode, setFileMode)
import System.Process (
  CreateProcess (..),
  StdStream (CreatePipe, UseHandle),
  proc,
  readProcess,
  withCreateProcess,
 )
import Test.Hydra.Prelude

data NodeLog
  = MsgNodeCmdSpec {NodeLog -> Text
cmd :: Text}
  | MsgCLI [Text]
  | MsgCLIStatus Text Text
  | MsgCLIRetry Text
  | MsgCLIRetryResult Text Int
  | MsgNodeStarting {NodeLog -> FilePath
stateDirectory :: FilePath}
  | MsgSocketIsReady SocketPath
  | MsgSynchronizing {NodeLog -> Centi
percentDone :: Centi}
  | MsgQueryGenesisParametersFailed {NodeLog -> Text
err :: Text}
  deriving stock (NodeLog -> NodeLog -> Bool
(NodeLog -> NodeLog -> Bool)
-> (NodeLog -> NodeLog -> Bool) -> Eq NodeLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeLog -> NodeLog -> Bool
== :: NodeLog -> NodeLog -> Bool
$c/= :: NodeLog -> NodeLog -> Bool
/= :: NodeLog -> NodeLog -> Bool
Eq, Int -> NodeLog -> ShowS
[NodeLog] -> ShowS
NodeLog -> FilePath
(Int -> NodeLog -> ShowS)
-> (NodeLog -> FilePath) -> ([NodeLog] -> ShowS) -> Show NodeLog
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeLog -> ShowS
showsPrec :: Int -> NodeLog -> ShowS
$cshow :: NodeLog -> FilePath
show :: NodeLog -> FilePath
$cshowList :: [NodeLog] -> ShowS
showList :: [NodeLog] -> ShowS
Show, (forall x. NodeLog -> Rep NodeLog x)
-> (forall x. Rep NodeLog x -> NodeLog) -> Generic NodeLog
forall x. Rep NodeLog x -> NodeLog
forall x. NodeLog -> Rep NodeLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NodeLog -> Rep NodeLog x
from :: forall x. NodeLog -> Rep NodeLog x
$cto :: forall x. Rep NodeLog x -> NodeLog
to :: forall x. Rep NodeLog x -> NodeLog
Generic)
  deriving anyclass ([NodeLog] -> Value
[NodeLog] -> Encoding
NodeLog -> Bool
NodeLog -> Value
NodeLog -> Encoding
(NodeLog -> Value)
-> (NodeLog -> Encoding)
-> ([NodeLog] -> Value)
-> ([NodeLog] -> Encoding)
-> (NodeLog -> Bool)
-> ToJSON NodeLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: NodeLog -> Value
toJSON :: NodeLog -> Value
$ctoEncoding :: NodeLog -> Encoding
toEncoding :: NodeLog -> Encoding
$ctoJSONList :: [NodeLog] -> Value
toJSONList :: [NodeLog] -> Value
$ctoEncodingList :: [NodeLog] -> Encoding
toEncodingList :: [NodeLog] -> Encoding
$comitField :: NodeLog -> Bool
omitField :: NodeLog -> Bool
ToJSON, Maybe NodeLog
Value -> Parser [NodeLog]
Value -> Parser NodeLog
(Value -> Parser NodeLog)
-> (Value -> Parser [NodeLog]) -> Maybe NodeLog -> FromJSON NodeLog
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser NodeLog
parseJSON :: Value -> Parser NodeLog
$cparseJSONList :: Value -> Parser [NodeLog]
parseJSONList :: Value -> Parser [NodeLog]
$comittedField :: Maybe NodeLog
omittedField :: Maybe NodeLog
FromJSON)

type Port = Int

newtype NodeId = NodeId Int
  deriving newtype (NodeId -> NodeId -> Bool
(NodeId -> NodeId -> Bool)
-> (NodeId -> NodeId -> Bool) -> Eq NodeId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeId -> NodeId -> Bool
== :: NodeId -> NodeId -> Bool
$c/= :: NodeId -> NodeId -> Bool
/= :: NodeId -> NodeId -> Bool
Eq, Int -> NodeId -> ShowS
[NodeId] -> ShowS
NodeId -> FilePath
(Int -> NodeId -> ShowS)
-> (NodeId -> FilePath) -> ([NodeId] -> ShowS) -> Show NodeId
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeId -> ShowS
showsPrec :: Int -> NodeId -> ShowS
$cshow :: NodeId -> FilePath
show :: NodeId -> FilePath
$cshowList :: [NodeId] -> ShowS
showList :: [NodeId] -> ShowS
Show, Integer -> NodeId
NodeId -> NodeId
NodeId -> NodeId -> NodeId
(NodeId -> NodeId -> NodeId)
-> (NodeId -> NodeId -> NodeId)
-> (NodeId -> NodeId -> NodeId)
-> (NodeId -> NodeId)
-> (NodeId -> NodeId)
-> (NodeId -> NodeId)
-> (Integer -> NodeId)
-> Num NodeId
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: NodeId -> NodeId -> NodeId
+ :: NodeId -> NodeId -> NodeId
$c- :: NodeId -> NodeId -> NodeId
- :: NodeId -> NodeId -> NodeId
$c* :: NodeId -> NodeId -> NodeId
* :: NodeId -> NodeId -> NodeId
$cnegate :: NodeId -> NodeId
negate :: NodeId -> NodeId
$cabs :: NodeId -> NodeId
abs :: NodeId -> NodeId
$csignum :: NodeId -> NodeId
signum :: NodeId -> NodeId
$cfromInteger :: Integer -> NodeId
fromInteger :: Integer -> NodeId
Num, [NodeId] -> Value
[NodeId] -> Encoding
NodeId -> Bool
NodeId -> Value
NodeId -> Encoding
(NodeId -> Value)
-> (NodeId -> Encoding)
-> ([NodeId] -> Value)
-> ([NodeId] -> Encoding)
-> (NodeId -> Bool)
-> ToJSON NodeId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: NodeId -> Value
toJSON :: NodeId -> Value
$ctoEncoding :: NodeId -> Encoding
toEncoding :: NodeId -> Encoding
$ctoJSONList :: [NodeId] -> Value
toJSONList :: [NodeId] -> Value
$ctoEncodingList :: [NodeId] -> Encoding
toEncodingList :: [NodeId] -> Encoding
$comitField :: NodeId -> Bool
omitField :: NodeId -> Bool
ToJSON, Maybe NodeId
Value -> Parser [NodeId]
Value -> Parser NodeId
(Value -> Parser NodeId)
-> (Value -> Parser [NodeId]) -> Maybe NodeId -> FromJSON NodeId
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser NodeId
parseJSON :: Value -> Parser NodeId
$cparseJSONList :: Value -> Parser [NodeId]
parseJSONList :: Value -> Parser [NodeId]
$comittedField :: Maybe NodeId
omittedField :: Maybe NodeId
FromJSON)

-- | Configuration parameters for a single node devnet
data DevnetConfig = DevnetConfig
  { DevnetConfig -> FilePath
stateDirectory :: FilePath
  -- ^ Parent state directory
  , DevnetConfig -> UTCTime
systemStart :: UTCTime
  -- ^ Blockchain start time
  , DevnetConfig -> PortsConfig
ports :: PortsConfig
  -- ^ A list of port
  }
  deriving stock (DevnetConfig -> DevnetConfig -> Bool
(DevnetConfig -> DevnetConfig -> Bool)
-> (DevnetConfig -> DevnetConfig -> Bool) -> Eq DevnetConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DevnetConfig -> DevnetConfig -> Bool
== :: DevnetConfig -> DevnetConfig -> Bool
$c/= :: DevnetConfig -> DevnetConfig -> Bool
/= :: DevnetConfig -> DevnetConfig -> Bool
Eq, Int -> DevnetConfig -> ShowS
[DevnetConfig] -> ShowS
DevnetConfig -> FilePath
(Int -> DevnetConfig -> ShowS)
-> (DevnetConfig -> FilePath)
-> ([DevnetConfig] -> ShowS)
-> Show DevnetConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DevnetConfig -> ShowS
showsPrec :: Int -> DevnetConfig -> ShowS
$cshow :: DevnetConfig -> FilePath
show :: DevnetConfig -> FilePath
$cshowList :: [DevnetConfig] -> ShowS
showList :: [DevnetConfig] -> ShowS
Show, (forall x. DevnetConfig -> Rep DevnetConfig x)
-> (forall x. Rep DevnetConfig x -> DevnetConfig)
-> Generic DevnetConfig
forall x. Rep DevnetConfig x -> DevnetConfig
forall x. DevnetConfig -> Rep DevnetConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DevnetConfig -> Rep DevnetConfig x
from :: forall x. DevnetConfig -> Rep DevnetConfig x
$cto :: forall x. Rep DevnetConfig x -> DevnetConfig
to :: forall x. Rep DevnetConfig x -> DevnetConfig
Generic)
  deriving anyclass ([DevnetConfig] -> Value
[DevnetConfig] -> Encoding
DevnetConfig -> Bool
DevnetConfig -> Value
DevnetConfig -> Encoding
(DevnetConfig -> Value)
-> (DevnetConfig -> Encoding)
-> ([DevnetConfig] -> Value)
-> ([DevnetConfig] -> Encoding)
-> (DevnetConfig -> Bool)
-> ToJSON DevnetConfig
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: DevnetConfig -> Value
toJSON :: DevnetConfig -> Value
$ctoEncoding :: DevnetConfig -> Encoding
toEncoding :: DevnetConfig -> Encoding
$ctoJSONList :: [DevnetConfig] -> Value
toJSONList :: [DevnetConfig] -> Value
$ctoEncodingList :: [DevnetConfig] -> Encoding
toEncodingList :: [DevnetConfig] -> Encoding
$comitField :: DevnetConfig -> Bool
omitField :: DevnetConfig -> Bool
ToJSON, Maybe DevnetConfig
Value -> Parser [DevnetConfig]
Value -> Parser DevnetConfig
(Value -> Parser DevnetConfig)
-> (Value -> Parser [DevnetConfig])
-> Maybe DevnetConfig
-> FromJSON DevnetConfig
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser DevnetConfig
parseJSON :: Value -> Parser DevnetConfig
$cparseJSONList :: Value -> Parser [DevnetConfig]
parseJSONList :: Value -> Parser [DevnetConfig]
$comittedField :: Maybe DevnetConfig
omittedField :: Maybe DevnetConfig
FromJSON)

-- | Arguments given to the 'cardano-node' command-line to run a node.
data CardanoNodeArgs = CardanoNodeArgs
  { CardanoNodeArgs -> FilePath
nodeSocket :: FilePath
  , CardanoNodeArgs -> FilePath
nodeConfigFile :: FilePath
  , CardanoNodeArgs -> FilePath
nodeByronGenesisFile :: FilePath
  , CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile :: FilePath
  , CardanoNodeArgs -> FilePath
nodeAlonzoGenesisFile :: FilePath
  , CardanoNodeArgs -> FilePath
nodeConwayGenesisFile :: FilePath
  , CardanoNodeArgs -> FilePath
nodeTopologyFile :: FilePath
  , CardanoNodeArgs -> FilePath
nodeDatabaseDir :: FilePath
  , CardanoNodeArgs -> Maybe FilePath
nodeDlgCertFile :: Maybe FilePath
  , CardanoNodeArgs -> Maybe FilePath
nodeSignKeyFile :: Maybe FilePath
  , CardanoNodeArgs -> Maybe FilePath
nodeOpCertFile :: Maybe FilePath
  , CardanoNodeArgs -> Maybe FilePath
nodeKesKeyFile :: Maybe FilePath
  , CardanoNodeArgs -> Maybe FilePath
nodeVrfKeyFile :: Maybe FilePath
  , CardanoNodeArgs -> Maybe Int
nodePort :: Maybe Port
  }

defaultCardanoNodeArgs :: CardanoNodeArgs
defaultCardanoNodeArgs :: CardanoNodeArgs
defaultCardanoNodeArgs =
  CardanoNodeArgs
    { $sel:nodeSocket:CardanoNodeArgs :: FilePath
nodeSocket = FilePath
"node.socket"
    , $sel:nodeConfigFile:CardanoNodeArgs :: FilePath
nodeConfigFile = FilePath
"cardano-node.json"
    , $sel:nodeByronGenesisFile:CardanoNodeArgs :: FilePath
nodeByronGenesisFile = FilePath
"genesis-byron.json"
    , $sel:nodeShelleyGenesisFile:CardanoNodeArgs :: FilePath
nodeShelleyGenesisFile = FilePath
"genesis-shelley.json"
    , $sel:nodeAlonzoGenesisFile:CardanoNodeArgs :: FilePath
nodeAlonzoGenesisFile = FilePath
"genesis-alonzo.json"
    , $sel:nodeConwayGenesisFile:CardanoNodeArgs :: FilePath
nodeConwayGenesisFile = FilePath
"genesis-conway.json"
    , $sel:nodeTopologyFile:CardanoNodeArgs :: FilePath
nodeTopologyFile = FilePath
"topology.json"
    , $sel:nodeDatabaseDir:CardanoNodeArgs :: FilePath
nodeDatabaseDir = FilePath
"db"
    , $sel:nodeDlgCertFile:CardanoNodeArgs :: Maybe FilePath
nodeDlgCertFile = Maybe FilePath
forall a. Maybe a
Nothing
    , $sel:nodeSignKeyFile:CardanoNodeArgs :: Maybe FilePath
nodeSignKeyFile = Maybe FilePath
forall a. Maybe a
Nothing
    , $sel:nodeOpCertFile:CardanoNodeArgs :: Maybe FilePath
nodeOpCertFile = Maybe FilePath
forall a. Maybe a
Nothing
    , $sel:nodeKesKeyFile:CardanoNodeArgs :: Maybe FilePath
nodeKesKeyFile = Maybe FilePath
forall a. Maybe a
Nothing
    , $sel:nodeVrfKeyFile:CardanoNodeArgs :: Maybe FilePath
nodeVrfKeyFile = Maybe FilePath
forall a. Maybe a
Nothing
    , $sel:nodePort:CardanoNodeArgs :: Maybe Int
nodePort = Maybe Int
forall a. Maybe a
Nothing
    }

-- | Configuration of ports from the perspective of a peer in the context of a
-- fully sockected topology.
data PortsConfig = PortsConfig
  { PortsConfig -> Int
ours :: Port
  -- ^ Our node TCP port.
  , PortsConfig -> [Int]
peers :: [Port]
  -- ^ Other peers TCP ports.
  }
  deriving stock (Int -> PortsConfig -> ShowS
[PortsConfig] -> ShowS
PortsConfig -> FilePath
(Int -> PortsConfig -> ShowS)
-> (PortsConfig -> FilePath)
-> ([PortsConfig] -> ShowS)
-> Show PortsConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PortsConfig -> ShowS
showsPrec :: Int -> PortsConfig -> ShowS
$cshow :: PortsConfig -> FilePath
show :: PortsConfig -> FilePath
$cshowList :: [PortsConfig] -> ShowS
showList :: [PortsConfig] -> ShowS
Show, PortsConfig -> PortsConfig -> Bool
(PortsConfig -> PortsConfig -> Bool)
-> (PortsConfig -> PortsConfig -> Bool) -> Eq PortsConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PortsConfig -> PortsConfig -> Bool
== :: PortsConfig -> PortsConfig -> Bool
$c/= :: PortsConfig -> PortsConfig -> Bool
/= :: PortsConfig -> PortsConfig -> Bool
Eq, (forall x. PortsConfig -> Rep PortsConfig x)
-> (forall x. Rep PortsConfig x -> PortsConfig)
-> Generic PortsConfig
forall x. Rep PortsConfig x -> PortsConfig
forall x. PortsConfig -> Rep PortsConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PortsConfig -> Rep PortsConfig x
from :: forall x. PortsConfig -> Rep PortsConfig x
$cto :: forall x. Rep PortsConfig x -> PortsConfig
to :: forall x. Rep PortsConfig x -> PortsConfig
Generic)
  deriving anyclass ([PortsConfig] -> Value
[PortsConfig] -> Encoding
PortsConfig -> Bool
PortsConfig -> Value
PortsConfig -> Encoding
(PortsConfig -> Value)
-> (PortsConfig -> Encoding)
-> ([PortsConfig] -> Value)
-> ([PortsConfig] -> Encoding)
-> (PortsConfig -> Bool)
-> ToJSON PortsConfig
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: PortsConfig -> Value
toJSON :: PortsConfig -> Value
$ctoEncoding :: PortsConfig -> Encoding
toEncoding :: PortsConfig -> Encoding
$ctoJSONList :: [PortsConfig] -> Value
toJSONList :: [PortsConfig] -> Value
$ctoEncodingList :: [PortsConfig] -> Encoding
toEncodingList :: [PortsConfig] -> Encoding
$comitField :: PortsConfig -> Bool
omitField :: PortsConfig -> Bool
ToJSON, Maybe PortsConfig
Value -> Parser [PortsConfig]
Value -> Parser PortsConfig
(Value -> Parser PortsConfig)
-> (Value -> Parser [PortsConfig])
-> Maybe PortsConfig
-> FromJSON PortsConfig
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser PortsConfig
parseJSON :: Value -> Parser PortsConfig
$cparseJSONList :: Value -> Parser [PortsConfig]
parseJSONList :: Value -> Parser [PortsConfig]
$comittedField :: Maybe PortsConfig
omittedField :: Maybe PortsConfig
FromJSON)

getCardanoNodeVersion :: IO String
getCardanoNodeVersion :: IO FilePath
getCardanoNodeVersion =
  FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"cardano-node" [FilePath
"--version"] FilePath
""

-- | Tries to find an communicate with an existing cardano-node running in given
-- work directory. NOTE: This is using the default node socket name as defined
-- by 'defaultCardanoNodeArgs'.
findRunningCardanoNode :: Tracer IO NodeLog -> FilePath -> KnownNetwork -> IO (Maybe RunningNode)
findRunningCardanoNode :: Tracer IO NodeLog
-> FilePath -> KnownNetwork -> IO (Maybe RunningNode)
findRunningCardanoNode Tracer IO NodeLog
tracer FilePath
workDir KnownNetwork
knownNetwork = do
  IO (GenesisParameters ShelleyEra)
-> IO (Either SomeException (GenesisParameters ShelleyEra))
forall e a. Exception e => IO a -> IO (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (NetworkId
-> SocketPath -> QueryPoint -> IO (GenesisParameters ShelleyEra)
queryGenesisParameters NetworkId
knownNetworkId SocketPath
socketPath QueryPoint
QueryTip) IO (Either SomeException (GenesisParameters ShelleyEra))
-> (Either SomeException (GenesisParameters ShelleyEra)
    -> IO (Maybe RunningNode))
-> IO (Maybe RunningNode)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (SomeException
e :: SomeException) ->
      Tracer IO NodeLog -> NodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tracer MsgQueryGenesisParametersFailed{$sel:err:MsgNodeCmdSpec :: Text
err = SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeException
e} IO () -> Maybe RunningNode -> IO (Maybe RunningNode)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe RunningNode
forall a. Maybe a
Nothing
    Right GenesisParameters{Rational
protocolParamActiveSlotsCoefficient :: Rational
protocolParamActiveSlotsCoefficient :: forall era. GenesisParameters era -> Rational
protocolParamActiveSlotsCoefficient, NominalDiffTime
protocolParamSlotLength :: NominalDiffTime
protocolParamSlotLength :: forall era. GenesisParameters era -> NominalDiffTime
protocolParamSlotLength} ->
      Maybe RunningNode -> IO (Maybe RunningNode)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RunningNode -> IO (Maybe RunningNode))
-> Maybe RunningNode -> IO (Maybe RunningNode)
forall a b. (a -> b) -> a -> b
$
        RunningNode -> Maybe RunningNode
forall a. a -> Maybe a
Just
          RunningNode
            { $sel:networkId:RunningNode :: NetworkId
networkId = NetworkId
knownNetworkId
            , $sel:nodeSocket:RunningNode :: SocketPath
nodeSocket = SocketPath
socketPath
            , $sel:blockTime:RunningNode :: NominalDiffTime
blockTime =
                NominalDiffTime -> Rational -> NominalDiffTime
computeBlockTime
                  NominalDiffTime
protocolParamSlotLength
                  Rational
protocolParamActiveSlotsCoefficient
            }
 where
  knownNetworkId :: NetworkId
knownNetworkId = KnownNetwork -> NetworkId
toNetworkId KnownNetwork
knownNetwork

  socketPath :: SocketPath
socketPath = FilePath -> SocketPath
forall content (direction :: FileDirection).
FilePath -> File content direction
File (FilePath -> SocketPath) -> FilePath -> SocketPath
forall a b. (a -> b) -> a -> b
$ FilePath
workDir FilePath -> ShowS
</> FilePath
nodeSocket

  CardanoNodeArgs{FilePath
$sel:nodeSocket:CardanoNodeArgs :: CardanoNodeArgs -> FilePath
nodeSocket :: FilePath
nodeSocket} = CardanoNodeArgs
defaultCardanoNodeArgs

-- | Start a single cardano-node devnet using the config from config/ and
-- credentials from config/credentials/. Only the 'Faucet' actor will receive
-- "initialFunds". Use 'seedFromFaucet' to distribute funds other wallets.
withCardanoNodeDevnet ::
  Tracer IO NodeLog ->
  -- | State directory in which credentials, db & logs are persisted.
  FilePath ->
  (RunningNode -> IO a) ->
  IO a
withCardanoNodeDevnet :: forall a.
Tracer IO NodeLog -> FilePath -> (RunningNode -> IO a) -> IO a
withCardanoNodeDevnet Tracer IO NodeLog
tracer FilePath
stateDirectory RunningNode -> IO a
action = do
  CardanoNodeArgs
args <- FilePath -> IO CardanoNodeArgs
setupCardanoDevnet FilePath
stateDirectory
  Tracer IO NodeLog
-> FilePath -> CardanoNodeArgs -> (RunningNode -> IO a) -> IO a
forall a.
Tracer IO NodeLog
-> FilePath -> CardanoNodeArgs -> (RunningNode -> IO a) -> IO a
withCardanoNode Tracer IO NodeLog
tracer FilePath
stateDirectory CardanoNodeArgs
args RunningNode -> IO a
action

-- | Run a cardano-node as normal network participant on a known network.
withCardanoNodeOnKnownNetwork ::
  Tracer IO NodeLog ->
  -- | State directory in which node db & logs are persisted.
  FilePath ->
  -- | A well-known Cardano network to connect to.
  KnownNetwork ->
  (RunningNode -> IO a) ->
  IO a
withCardanoNodeOnKnownNetwork :: forall a.
Tracer IO NodeLog
-> FilePath -> KnownNetwork -> (RunningNode -> IO a) -> IO a
withCardanoNodeOnKnownNetwork Tracer IO NodeLog
tracer FilePath
stateDirectory KnownNetwork
knownNetwork RunningNode -> IO a
action = do
  IO ()
copyKnownNetworkFiles
  Tracer IO NodeLog
-> FilePath -> CardanoNodeArgs -> (RunningNode -> IO a) -> IO a
forall a.
Tracer IO NodeLog
-> FilePath -> CardanoNodeArgs -> (RunningNode -> IO a) -> IO a
withCardanoNode Tracer IO NodeLog
tracer FilePath
stateDirectory CardanoNodeArgs
args RunningNode -> IO a
action
 where
  args :: CardanoNodeArgs
args =
    CardanoNodeArgs
defaultCardanoNodeArgs
      { nodeConfigFile = "config.json"
      , nodeTopologyFile = "topology.json"
      , nodeByronGenesisFile = "byron-genesis.json"
      , nodeShelleyGenesisFile = "shelley-genesis.json"
      , nodeAlonzoGenesisFile = "alonzo-genesis.json"
      , nodeConwayGenesisFile = "conway-genesis.json"
      }

  -- Copy/download configuration files for a known network
  copyKnownNetworkFiles :: IO ()
copyKnownNetworkFiles =
    [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
      [ FilePath
"config.json"
      , FilePath
"topology.json"
      , FilePath
"byron-genesis.json"
      , FilePath
"shelley-genesis.json"
      , FilePath
"alonzo-genesis.json"
      , FilePath
"conway-genesis.json"
      ]
      ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
fn -> do
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
stateDirectory FilePath -> ShowS
</> ShowS
takeDirectory FilePath
fn
        FilePath -> IO ByteString
forall {f :: * -> *}.
(MonadThrow f, MonadIO f) =>
FilePath -> f ByteString
fetchConfigFile (FilePath
knownNetworkPath FilePath -> ShowS
</> FilePath
fn)
          IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS (FilePath
stateDirectory FilePath -> ShowS
</> FilePath
fn)

  knownNetworkPath :: FilePath
knownNetworkPath =
    FilePath
knownNetworkConfigBaseURL FilePath -> ShowS
</> FilePath
knownNetworkName

  -- Base path on remote
  knownNetworkConfigBaseURL :: FilePath
knownNetworkConfigBaseURL = FilePath
"https://book.world.dev.cardano.org/environments"

  -- Network name on remote
  knownNetworkName :: FilePath
knownNetworkName = case KnownNetwork
knownNetwork of
    KnownNetwork
Preview -> FilePath
"preview"
    KnownNetwork
Preproduction -> FilePath
"preprod"
    KnownNetwork
Mainnet -> FilePath
"mainnet"
    KnownNetwork
Sanchonet -> FilePath
"sanchonet"

  fetchConfigFile :: FilePath -> f ByteString
fetchConfigFile FilePath
path =
    FilePath -> f Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequestThrow FilePath
path f Request
-> (Request -> f (Response ByteString)) -> f (Response ByteString)
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> f (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpBS f (Response ByteString)
-> (Response ByteString -> ByteString) -> f ByteString
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody

-- | Setup the cardano-node to run a local devnet producing blocks. This copies
-- the appropriate files and prepares 'CardanoNodeArgs' for 'withCardanoNode'.
setupCardanoDevnet :: FilePath -> IO CardanoNodeArgs
setupCardanoDevnet :: FilePath -> IO CardanoNodeArgs
setupCardanoDevnet FilePath
stateDirectory = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
stateDirectory
  [FilePath
dlgCert, FilePath
signKey, FilePath
vrfKey, FilePath
kesKey, FilePath
opCert] <-
    (FilePath -> IO FilePath) -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
      FilePath -> IO FilePath
copyDevnetCredential
      [ FilePath
"byron-delegation.cert"
      , FilePath
"byron-delegate.key"
      , FilePath
"vrf.skey"
      , FilePath
"kes.skey"
      , FilePath
"opcert.cert"
      ]
  let args :: CardanoNodeArgs
args =
        CardanoNodeArgs
defaultCardanoNodeArgs
          { nodeDlgCertFile = Just dlgCert
          , nodeSignKeyFile = Just signKey
          , nodeVrfKeyFile = Just vrfKey
          , nodeKesKeyFile = Just kesKey
          , nodeOpCertFile = Just opCert
          }
  CardanoNodeArgs -> IO ()
copyDevnetFiles CardanoNodeArgs
args
  FilePath -> CardanoNodeArgs -> IO ()
refreshSystemStart FilePath
stateDirectory CardanoNodeArgs
args
  [Int] -> CardanoNodeArgs -> IO ()
writeTopology [] CardanoNodeArgs
args
  CardanoNodeArgs -> IO CardanoNodeArgs
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CardanoNodeArgs
args
 where
  copyDevnetCredential :: FilePath -> IO FilePath
copyDevnetCredential FilePath
file = do
    let destination :: FilePath
destination = FilePath
stateDirectory FilePath -> ShowS
</> FilePath
file
    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> IO Bool
doesFileExist FilePath
destination) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
file)
        IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS FilePath
destination
    FilePath -> FileMode -> IO ()
setFileMode FilePath
destination FileMode
ownerReadMode
    FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
file

  copyDevnetFiles :: CardanoNodeArgs -> IO ()
copyDevnetFiles CardanoNodeArgs
args = do
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"cardano-node.json")
      IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS
        (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConfigFile CardanoNodeArgs
args)
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-byron.json")
      IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS
        (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeByronGenesisFile CardanoNodeArgs
args)
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-shelley.json")
      IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS
        (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args)
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-alonzo.json")
      IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS
        (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeAlonzoGenesisFile CardanoNodeArgs
args)
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-conway.json")
      IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS
        (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConwayGenesisFile CardanoNodeArgs
args)

  writeTopology :: [Int] -> CardanoNodeArgs -> IO ()
writeTopology [Int]
peers CardanoNodeArgs
args =
    FilePath -> Value -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeTopologyFile CardanoNodeArgs
args) (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Int] -> Value
mkTopology [Int]
peers

-- | Modify the cardano-node configuration to fork into conway at given era
-- number.
forkIntoConwayInEpoch :: FilePath -> CardanoNodeArgs -> Natural -> IO ()
forkIntoConwayInEpoch :: FilePath -> CardanoNodeArgs -> Natural -> IO ()
forkIntoConwayInEpoch FilePath
stateDirectory CardanoNodeArgs
args Natural
n = do
  Value
config <-
    forall a. FromJSON a => FilePath -> IO a
unsafeDecodeJsonFile @Aeson.Value (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConfigFile CardanoNodeArgs
args)
      IO Value -> (Value -> Value) -> IO Value
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"TestConwayHardForkAtEpoch" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Natural -> Value
forall a. ToJSON a => a -> Value
toJSON Natural
n
  FilePath -> Value -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile
    (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConfigFile CardanoNodeArgs
args)
    Value
config

withCardanoNode ::
  Tracer IO NodeLog ->
  FilePath ->
  CardanoNodeArgs ->
  (RunningNode -> IO a) ->
  IO a
withCardanoNode :: forall a.
Tracer IO NodeLog
-> FilePath -> CardanoNodeArgs -> (RunningNode -> IO a) -> IO a
withCardanoNode Tracer IO NodeLog
tr FilePath
stateDirectory CardanoNodeArgs
args RunningNode -> IO a
action = do
  Tracer IO NodeLog -> NodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tr (NodeLog -> IO ()) -> NodeLog -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> NodeLog
MsgNodeCmdSpec (CmdSpec -> Text
forall b a. (Show a, IsString b) => a -> b
show (CmdSpec -> Text) -> CmdSpec -> Text
forall a b. (a -> b) -> a -> b
$ CreateProcess -> CmdSpec
cmdspec CreateProcess
process)
  FilePath -> (Handle -> IO a) -> IO a
forall a. FilePath -> (Handle -> IO a) -> IO a
withLogFile FilePath
logFilePath ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
out -> do
    Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
out BufferMode
NoBuffering
    CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
process{std_out = UseHandle out, std_err = CreatePipe} ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
 -> IO a)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$
      \Maybe Handle
_stdin Maybe Handle
_stdout Maybe Handle
mError ProcessHandle
processHandle ->
        (IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` IO ()
cleanupSocketFile) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
          IO Void -> IO a -> IO (Either Void a)
forall a b. IO a -> IO b -> IO (Either a b)
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> m b -> m (Either a b)
race (Text -> ProcessHandle -> Maybe Handle -> IO Void
checkProcessHasNotDied Text
"cardano-node" ProcessHandle
processHandle Maybe Handle
mError) IO a
waitForNode
            IO (Either Void a) -> (Either Void a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left{} -> Text -> IO a
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"should never been reached"
              Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
 where
  CardanoNodeArgs{FilePath
$sel:nodeSocket:CardanoNodeArgs :: CardanoNodeArgs -> FilePath
nodeSocket :: FilePath
nodeSocket} = CardanoNodeArgs
args

  process :: CreateProcess
process = Maybe FilePath -> CardanoNodeArgs -> CreateProcess
cardanoNodeProcess (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
stateDirectory) CardanoNodeArgs
args

  logFilePath :: FilePath
logFilePath = FilePath
stateDirectory FilePath -> ShowS
</> FilePath
"logs" FilePath -> ShowS
</> FilePath
"cardano-node.log"

  socketPath :: FilePath
socketPath = FilePath
stateDirectory FilePath -> ShowS
</> FilePath
nodeSocket

  waitForNode :: IO a
waitForNode = do
    let nodeSocketPath :: SocketPath
nodeSocketPath = FilePath -> SocketPath
forall content (direction :: FileDirection).
FilePath -> File content direction
File FilePath
socketPath
    Tracer IO NodeLog -> NodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tr (NodeLog -> IO ()) -> NodeLog -> IO ()
forall a b. (a -> b) -> a -> b
$ MsgNodeStarting{FilePath
$sel:stateDirectory:MsgNodeCmdSpec :: FilePath
stateDirectory :: FilePath
stateDirectory}
    SocketPath -> IO ()
waitForSocket SocketPath
nodeSocketPath
    Tracer IO NodeLog -> NodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tr (NodeLog -> IO ()) -> NodeLog -> IO ()
forall a b. (a -> b) -> a -> b
$ SocketPath -> NodeLog
MsgSocketIsReady SocketPath
nodeSocketPath
    Value
shelleyGenesis <- FilePath -> IO Value
readShelleyGenesisJSON (FilePath -> IO Value) -> FilePath -> IO Value
forall a b. (a -> b) -> a -> b
$ FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args
    RunningNode -> IO a
action
      RunningNode
        { $sel:nodeSocket:RunningNode :: SocketPath
nodeSocket = FilePath -> SocketPath
forall content (direction :: FileDirection).
FilePath -> File content direction
File (FilePath
stateDirectory FilePath -> ShowS
</> FilePath
nodeSocket)
        , $sel:networkId:RunningNode :: NetworkId
networkId = Value -> NetworkId
getShelleyGenesisNetworkId Value
shelleyGenesis
        , $sel:blockTime:RunningNode :: NominalDiffTime
blockTime = Value -> NominalDiffTime
getShelleyGenesisBlockTime Value
shelleyGenesis
        }

  cleanupSocketFile :: IO ()
cleanupSocketFile =
    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> IO Bool
doesFileExist FilePath
socketPath) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> IO ()
removeFile FilePath
socketPath

  readShelleyGenesisJSON :: FilePath -> IO Value
readShelleyGenesisJSON = FilePath -> IO ByteString
forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
readFileBS (FilePath -> IO ByteString)
-> (ByteString -> IO Value) -> FilePath -> IO Value
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ByteString -> IO Value
forall a. FromJSON a => ByteString -> IO a
unsafeDecodeJson

  -- Read 'NetworkId' from shelley genesis JSON file
  getShelleyGenesisNetworkId :: Value -> NetworkId
  getShelleyGenesisNetworkId :: Value -> NetworkId
getShelleyGenesisNetworkId Value
json = do
    if Value
json Value -> Getting (Endo Value) Value Value -> Value
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"networkId" Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
"Mainnet"
      then NetworkId
Api.Mainnet
      else do
        let magic :: Scientific
magic = Value
json Value -> Getting (Endo Scientific) Value Scientific -> Scientific
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"networkMagic" ((Value -> Const (Endo Scientific) Value)
 -> Value -> Const (Endo Scientific) Value)
-> Getting (Endo Scientific) Value Scientific
-> Getting (Endo Scientific) Value Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo Scientific) Value Scientific
forall t. AsNumber t => Prism' t Scientific
Prism' Value Scientific
_Number
        NetworkMagic -> NetworkId
Api.Testnet (Word32 -> NetworkMagic
Api.NetworkMagic (Word32 -> NetworkMagic) -> Word32 -> NetworkMagic
forall a b. (a -> b) -> a -> b
$ Scientific -> Word32
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Scientific
magic)

  -- Read expected time between blocks from shelley genesis
  getShelleyGenesisBlockTime :: Value -> NominalDiffTime
  getShelleyGenesisBlockTime :: Value -> NominalDiffTime
getShelleyGenesisBlockTime Value
json = do
    let slotLength :: Scientific
slotLength = Value
json Value -> Getting (Endo Scientific) Value Scientific -> Scientific
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"slotLength" ((Value -> Const (Endo Scientific) Value)
 -> Value -> Const (Endo Scientific) Value)
-> Getting (Endo Scientific) Value Scientific
-> Getting (Endo Scientific) Value Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo Scientific) Value Scientific
forall t. AsNumber t => Prism' t Scientific
Prism' Value Scientific
_Number
    let activeSlotsCoeff :: Scientific
activeSlotsCoeff = Value
json Value -> Getting (Endo Scientific) Value Scientific -> Scientific
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"activeSlotsCoeff" ((Value -> Const (Endo Scientific) Value)
 -> Value -> Const (Endo Scientific) Value)
-> Getting (Endo Scientific) Value Scientific
-> Getting (Endo Scientific) Value Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo Scientific) Value Scientific
forall t. AsNumber t => Prism' t Scientific
Prism' Value Scientific
_Number
    NominalDiffTime -> Rational -> NominalDiffTime
computeBlockTime (Scientific -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Scientific
slotLength) (Scientific -> Rational
forall a. Real a => a -> Rational
toRational Scientific
activeSlotsCoeff)

-- | Compute the block time (expected time between blocks) given a slot length
-- as diff time and active slot coefficient.
computeBlockTime :: NominalDiffTime -> Rational -> NominalDiffTime
computeBlockTime :: NominalDiffTime -> Rational -> NominalDiffTime
computeBlockTime NominalDiffTime
slotLength Rational
activeSlotsCoeff =
  NominalDiffTime
slotLength NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ Rational -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
activeSlotsCoeff

-- | Wait until the node is fully caught up with the network. This can take a
-- while!
waitForFullySynchronized ::
  Tracer IO NodeLog ->
  RunningNode ->
  IO ()
waitForFullySynchronized :: Tracer IO NodeLog -> RunningNode -> IO ()
waitForFullySynchronized Tracer IO NodeLog
tracer RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = do
  SystemStart
systemStart <- NetworkId -> SocketPath -> QueryPoint -> IO SystemStart
querySystemStart NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip
  SystemStart -> IO ()
check SystemStart
systemStart
 where
  check :: SystemStart -> IO ()
check SystemStart
systemStart = do
    RelativeTime
targetTime <- SystemStart -> UTCTime -> RelativeTime
toRelativeTime SystemStart
systemStart (UTCTime -> RelativeTime) -> IO UTCTime -> IO RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
    EraHistory
eraHistory <- NetworkId -> SocketPath -> QueryPoint -> IO EraHistory
queryEraHistory NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip
    SlotNo
tipSlotNo <- NetworkId -> SocketPath -> IO SlotNo
queryTipSlotNo NetworkId
networkId SocketPath
nodeSocket
    (RelativeTime
tipTime, SlotLength
_slotLength) <- (PastHorizonException -> IO (RelativeTime, SlotLength))
-> ((RelativeTime, SlotLength) -> IO (RelativeTime, SlotLength))
-> Either PastHorizonException (RelativeTime, SlotLength)
-> IO (RelativeTime, SlotLength)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PastHorizonException -> IO (RelativeTime, SlotLength)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (RelativeTime, SlotLength) -> IO (RelativeTime, SlotLength)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PastHorizonException (RelativeTime, SlotLength)
 -> IO (RelativeTime, SlotLength))
-> Either PastHorizonException (RelativeTime, SlotLength)
-> IO (RelativeTime, SlotLength)
forall a b. (a -> b) -> a -> b
$ SlotNo
-> EraHistory
-> Either PastHorizonException (RelativeTime, SlotLength)
getProgress SlotNo
tipSlotNo EraHistory
eraHistory
    let timeDifference :: NominalDiffTime
timeDifference = RelativeTime -> RelativeTime -> NominalDiffTime
diffRelativeTime RelativeTime
targetTime RelativeTime
tipTime
    let percentDone :: Centi
percentDone = NominalDiffTime -> Centi
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime
100.0 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* RelativeTime -> NominalDiffTime
getRelativeTime RelativeTime
tipTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ RelativeTime -> NominalDiffTime
getRelativeTime RelativeTime
targetTime)
    Tracer IO NodeLog -> NodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tracer (NodeLog -> IO ()) -> NodeLog -> IO ()
forall a b. (a -> b) -> a -> b
$ MsgSynchronizing{Centi
$sel:percentDone:MsgNodeCmdSpec :: Centi
percentDone :: Centi
percentDone}
    if NominalDiffTime
timeDifference NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
blockTime
      then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      else DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
3 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SystemStart -> IO ()
check SystemStart
systemStart

-- | Wait for the node socket file to become available.
waitForSocket :: SocketPath -> IO ()
waitForSocket :: SocketPath -> IO ()
waitForSocket SocketPath
socketPath =
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ SocketPath -> FilePath
forall content (direction :: FileDirection).
File content direction -> FilePath
unFile SocketPath
socketPath) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1
    SocketPath -> IO ()
waitForSocket SocketPath
socketPath

-- | Generate command-line arguments for launching @cardano-node@.
cardanoNodeProcess :: Maybe FilePath -> CardanoNodeArgs -> CreateProcess
cardanoNodeProcess :: Maybe FilePath -> CardanoNodeArgs -> CreateProcess
cardanoNodeProcess Maybe FilePath
cwd CardanoNodeArgs
args =
  (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"cardano-node" [FilePath]
strArgs){cwd}
 where
  CardanoNodeArgs
    { FilePath
$sel:nodeConfigFile:CardanoNodeArgs :: CardanoNodeArgs -> FilePath
nodeConfigFile :: FilePath
nodeConfigFile
    , FilePath
$sel:nodeTopologyFile:CardanoNodeArgs :: CardanoNodeArgs -> FilePath
nodeTopologyFile :: FilePath
nodeTopologyFile
    , FilePath
$sel:nodeDatabaseDir:CardanoNodeArgs :: CardanoNodeArgs -> FilePath
nodeDatabaseDir :: FilePath
nodeDatabaseDir
    , FilePath
$sel:nodeSocket:CardanoNodeArgs :: CardanoNodeArgs -> FilePath
nodeSocket :: FilePath
nodeSocket
    , Maybe Int
$sel:nodePort:CardanoNodeArgs :: CardanoNodeArgs -> Maybe Int
nodePort :: Maybe Int
nodePort
    , Maybe FilePath
$sel:nodeSignKeyFile:CardanoNodeArgs :: CardanoNodeArgs -> Maybe FilePath
nodeSignKeyFile :: Maybe FilePath
nodeSignKeyFile
    , Maybe FilePath
$sel:nodeDlgCertFile:CardanoNodeArgs :: CardanoNodeArgs -> Maybe FilePath
nodeDlgCertFile :: Maybe FilePath
nodeDlgCertFile
    , Maybe FilePath
$sel:nodeOpCertFile:CardanoNodeArgs :: CardanoNodeArgs -> Maybe FilePath
nodeOpCertFile :: Maybe FilePath
nodeOpCertFile
    , Maybe FilePath
$sel:nodeKesKeyFile:CardanoNodeArgs :: CardanoNodeArgs -> Maybe FilePath
nodeKesKeyFile :: Maybe FilePath
nodeKesKeyFile
    , Maybe FilePath
$sel:nodeVrfKeyFile:CardanoNodeArgs :: CardanoNodeArgs -> Maybe FilePath
nodeVrfKeyFile :: Maybe FilePath
nodeVrfKeyFile
    } = CardanoNodeArgs
args

  strArgs :: [FilePath]
strArgs =
    FilePath
"run"
      FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [[FilePath]] -> [FilePath]
forall a. Monoid a => [a] -> a
mconcat
        [ [FilePath
"--config", FilePath
nodeConfigFile]
        , [FilePath
"--topology", FilePath
nodeTopologyFile]
        , [FilePath
"--database-path", FilePath
nodeDatabaseDir]
        , [FilePath
"--socket-path", FilePath
nodeSocket]
        , FilePath -> Maybe FilePath -> [FilePath]
forall a. a -> Maybe a -> [a]
opt FilePath
"--port" (Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show (Int -> FilePath) -> Maybe Int -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
nodePort)
        , FilePath -> Maybe FilePath -> [FilePath]
forall a. a -> Maybe a -> [a]
opt FilePath
"--byron-signing-key" Maybe FilePath
nodeSignKeyFile
        , FilePath -> Maybe FilePath -> [FilePath]
forall a. a -> Maybe a -> [a]
opt FilePath
"--byron-delegation-certificate" Maybe FilePath
nodeDlgCertFile
        , FilePath -> Maybe FilePath -> [FilePath]
forall a. a -> Maybe a -> [a]
opt FilePath
"--shelley-operational-certificate" Maybe FilePath
nodeOpCertFile
        , FilePath -> Maybe FilePath -> [FilePath]
forall a. a -> Maybe a -> [a]
opt FilePath
"--shelley-kes-key" Maybe FilePath
nodeKesKeyFile
        , FilePath -> Maybe FilePath -> [FilePath]
forall a. a -> Maybe a -> [a]
opt FilePath
"--shelley-vrf-key" Maybe FilePath
nodeVrfKeyFile
        ]

  opt :: a -> Maybe a -> [a]
  opt :: forall a. a -> Maybe a -> [a]
opt a
arg = \case
    Maybe a
Nothing -> []
    Just a
val -> [a
arg, a
val]

-- | Initialize the system start time to now (modulo a small offset needed to
-- give time to the system to bootstrap correctly).
initSystemStart :: IO UTCTime
initSystemStart :: IO UTCTime
initSystemStart =
  NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
1 (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime

-- | Re-generate configuration and genesis files with fresh system start times.
refreshSystemStart ::
  -- | Working directory in which paths of 'CardanoNodeArgs' are resolved.
  FilePath ->
  CardanoNodeArgs ->
  IO ()
refreshSystemStart :: FilePath -> CardanoNodeArgs -> IO ()
refreshSystemStart FilePath
stateDirectory CardanoNodeArgs
args = do
  UTCTime
systemStart <- IO UTCTime
initSystemStart
  let startTime :: Int
startTime = forall a b. (RealFrac a, Integral b) => a -> b
round @_ @Int (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
systemStart
  Value
byronGenesis <-
    forall a. FromJSON a => FilePath -> IO a
unsafeDecodeJsonFile @Aeson.Value (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeByronGenesisFile CardanoNodeArgs
args)
      IO Value -> (Value -> Value) -> IO Value
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"startTime" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
startTime

  let systemStartUTC :: UTCTime
systemStartUTC =
        NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime)
-> (Int -> NominalDiffTime) -> Int -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> NominalDiffTime)
-> (Int -> Rational) -> Int -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Rational
forall a. Real a => a -> Rational
toRational (Int -> UTCTime) -> Int -> UTCTime
forall a b. (a -> b) -> a -> b
$ Int
startTime
  Value
shelleyGenesis <-
    forall a. FromJSON a => FilePath -> IO a
unsafeDecodeJsonFile @Aeson.Value (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args)
      IO Value -> (Value -> Value) -> IO Value
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"systemStart" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON UTCTime
systemStartUTC

  Value
config <-
    forall a. FromJSON a => FilePath -> IO a
unsafeDecodeJsonFile @Aeson.Value (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConfigFile CardanoNodeArgs
args)
      IO Value -> (Value -> Value) -> IO Value
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"ByronGenesisFile" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text -> Value
forall a. ToJSON a => a -> Value
toJSON (FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ CardanoNodeArgs -> FilePath
nodeByronGenesisFile CardanoNodeArgs
args))
        (Value -> Value) -> (Value -> Value) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"ShelleyGenesisFile" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text -> Value
String (FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args))

  FilePath -> Value -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile
    (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeByronGenesisFile CardanoNodeArgs
args)
    Value
byronGenesis
  FilePath -> Value -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile
    (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args)
    Value
shelleyGenesis
  FilePath -> Value -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConfigFile CardanoNodeArgs
args) Value
config

-- | Generate a topology file from a list of peers.
mkTopology :: [Port] -> Aeson.Value
mkTopology :: [Int] -> Value
mkTopology [Int]
peers =
  [Pair] -> Value
Aeson.object [Key
"Producers" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int -> Value) -> [Int] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Value
encodePeer [Int]
peers]
 where
  encodePeer :: Int -> Aeson.Value
  encodePeer :: Int -> Value
encodePeer Int
port =
    [Pair] -> Value
Aeson.object
      [Key
"addr" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"127.0.0.1" :: Text), Key
"port" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
port, Key
"valency" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
1 :: Int)]

generateCardanoKey :: IO (VerificationKey PaymentKey, SigningKey PaymentKey)
generateCardanoKey :: IO (VerificationKey PaymentKey, SigningKey PaymentKey)
generateCardanoKey = do
  SigningKey PaymentKey
sk <- AsType PaymentKey -> IO (SigningKey PaymentKey)
forall (m :: * -> *) keyrole.
(MonadIO m, Key keyrole) =>
AsType keyrole -> m (SigningKey keyrole)
generateSigningKey AsType PaymentKey
AsPaymentKey
  (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk, SigningKey PaymentKey
sk)

data ProcessHasExited = ProcessHasExited Text ExitCode
  deriving stock (Int -> ProcessHasExited -> ShowS
[ProcessHasExited] -> ShowS
ProcessHasExited -> FilePath
(Int -> ProcessHasExited -> ShowS)
-> (ProcessHasExited -> FilePath)
-> ([ProcessHasExited] -> ShowS)
-> Show ProcessHasExited
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProcessHasExited -> ShowS
showsPrec :: Int -> ProcessHasExited -> ShowS
$cshow :: ProcessHasExited -> FilePath
show :: ProcessHasExited -> FilePath
$cshowList :: [ProcessHasExited] -> ShowS
showList :: [ProcessHasExited] -> ShowS
Show)

instance Exception ProcessHasExited

-- | Cardano-cli wrapper to query protocol parameters. While we have also client
-- functions in Hydra.Chain.CardanoClient and Hydra.Cluster.CardanoClient,
-- sometimes we deliberately want to use the cardano-cli to ensure
-- compatibility.
cliQueryProtocolParameters :: SocketPath -> NetworkId -> IO Value
cliQueryProtocolParameters :: SocketPath -> NetworkId -> IO Value
cliQueryProtocolParameters SocketPath
nodeSocket NetworkId
networkId = do
  FilePath
out <- FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
cmd [FilePath]
args FilePath
""
  ByteString -> IO Value
forall a. FromJSON a => ByteString -> IO a
unsafeDecodeJson (ByteString -> IO Value) -> ByteString -> IO Value
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
forall a. IsString a => FilePath -> a
fromString FilePath
out
 where
  cmd :: FilePath
cmd = FilePath
"cardano-cli"

  args :: [FilePath]
args =
    [ FilePath
"query"
    , FilePath
"protocol-parameters"
    , FilePath
"--socket-path"
    , SocketPath -> FilePath
forall content (direction :: FileDirection).
File content direction -> FilePath
unFile SocketPath
nodeSocket
    ]
      [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> case NetworkId
networkId of
        NetworkId
Api.Mainnet -> [FilePath
"--mainnet"]
        Api.Testnet (NetworkMagic Word32
magic) -> [FilePath
"--testnet-magic", Word32 -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Word32
magic]
      [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [ FilePath
"--out-file"
         , FilePath
"/dev/stdout"
         ]

--
-- Helpers
--

-- | Do something with an a JSON object. Fails if the given JSON value isn't an
-- object.
withObject :: (Aeson.Object -> Aeson.Object) -> Aeson.Value -> Aeson.Value
withObject :: (Object -> Object) -> Value -> Value
withObject Object -> Object
fn = \case
  Aeson.Object Object
m -> Object -> Value
Aeson.Object (Object -> Object
fn Object
m)
  Value
x -> Value
x

unsafeDecodeJson :: FromJSON a => ByteString -> IO a
unsafeDecodeJson :: forall a. FromJSON a => ByteString -> IO a
unsafeDecodeJson = (FilePath -> IO a) -> (a -> IO a) -> Either FilePath a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO a
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath a -> IO a)
-> (ByteString -> Either FilePath a) -> ByteString -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either FilePath a
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict

unsafeDecodeJsonFile :: FromJSON a => FilePath -> IO a
unsafeDecodeJsonFile :: forall a. FromJSON a => FilePath -> IO a
unsafeDecodeJsonFile = FilePath -> IO (Either FilePath a)
forall a. FromJSON a => FilePath -> IO (Either FilePath a)
Aeson.eitherDecodeFileStrict (FilePath -> IO (Either FilePath a))
-> (Either FilePath a -> IO a) -> FilePath -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (FilePath -> IO a) -> (a -> IO a) -> Either FilePath a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO a
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure