{-# LANGUAGE DuplicateRecordFields #-}

module CardanoNode where

import Hydra.Prelude

import Test.Network.Ports qualified as Ports

import Cardano.Slotting.Time (diffRelativeTime, getRelativeTime, toRelativeTime)
import CardanoClient (QueryPoint (QueryTip))
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.Aeson.Types qualified as Aeson
import Data.Fixed (Centi)
import Data.Text (pack)
import Data.Text qualified as Text
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Data.Vector qualified as Vector
import Hydra.Cardano.Api (
  Coin,
  File (..),
  NetworkId,
  NetworkMagic (..),
  SocketPath,
  TxId (..),
  UTxO,
  getProgress,
 )
import Hydra.Cardano.Api qualified as Api
import Hydra.Chain.Backend (ChainBackend (..))
import Hydra.Chain.Backend qualified as Backend
import Hydra.Chain.Blockfrost (runBlockfrostBackend)
import Hydra.Chain.CardanoClient (computeBlockTime)
import Hydra.Chain.Direct (runDirectBackend)
import Hydra.Cluster.Faucet (FaucetLog, publishOrReuseHydraScripts)
import Hydra.Cluster.Fixture qualified as Fixture
import Hydra.Cluster.Mithril (MithrilLog, downloadLatestSnapshotTo)
import Hydra.Cluster.Options (Options)
import Hydra.Cluster.Util (readConfigFile)
import Hydra.Options (BlockfrostOptions (..), ChainBackendOptions (..), DirectOptions (..), defaultBlockfrostOptions)
import Hydra.Options qualified as Options
import Network.HTTP.Simple (getResponseBody, httpBS, parseRequestThrow)
import System.Directory (
  createDirectoryIfMissing,
  doesDirectoryExist,
  doesFileExist,
  getCurrentDirectory,
  removeFile,
 )
import System.Exit (ExitCode (..))
import System.FilePath (
  takeDirectory,
  (</>),
 )
import System.Posix (ownerReadMode, setFileMode)
import System.Process (
  CreateProcess (..),
  StdStream (CreatePipe, UseHandle),
  proc,
  readProcess,
  terminateProcess,
  waitForProcess,
  withCreateProcess,
 )
import Test.Hydra.Prelude hiding (Blockfrost)
import Test.Hydra.Prelude qualified as TestPrelude

data HydraNodeLog
  = HydraNodeCommandSpec {HydraNodeLog -> Text
cmd :: Text}
  | NodeStarted {HydraNodeLog -> Int
nodeId :: Int}
  | SentMessage {nodeId :: Int, HydraNodeLog -> Value
message :: Aeson.Value}
  | StartWaiting {HydraNodeLog -> [Int]
nodeIds :: [Int], HydraNodeLog -> [Value]
messages :: [Aeson.Value]}
  | ReceivedMessage {nodeId :: Int, message :: Aeson.Value}
  | EndWaiting {nodeId :: Int}
  deriving stock (HydraNodeLog -> HydraNodeLog -> Bool
(HydraNodeLog -> HydraNodeLog -> Bool)
-> (HydraNodeLog -> HydraNodeLog -> Bool) -> Eq HydraNodeLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HydraNodeLog -> HydraNodeLog -> Bool
== :: HydraNodeLog -> HydraNodeLog -> Bool
$c/= :: HydraNodeLog -> HydraNodeLog -> Bool
/= :: HydraNodeLog -> HydraNodeLog -> Bool
Eq, Int -> HydraNodeLog -> ShowS
[HydraNodeLog] -> ShowS
HydraNodeLog -> FilePath
(Int -> HydraNodeLog -> ShowS)
-> (HydraNodeLog -> FilePath)
-> ([HydraNodeLog] -> ShowS)
-> Show HydraNodeLog
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HydraNodeLog -> ShowS
showsPrec :: Int -> HydraNodeLog -> ShowS
$cshow :: HydraNodeLog -> FilePath
show :: HydraNodeLog -> FilePath
$cshowList :: [HydraNodeLog] -> ShowS
showList :: [HydraNodeLog] -> ShowS
Show, (forall x. HydraNodeLog -> Rep HydraNodeLog x)
-> (forall x. Rep HydraNodeLog x -> HydraNodeLog)
-> Generic HydraNodeLog
forall x. Rep HydraNodeLog x -> HydraNodeLog
forall x. HydraNodeLog -> Rep HydraNodeLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HydraNodeLog -> Rep HydraNodeLog x
from :: forall x. HydraNodeLog -> Rep HydraNodeLog x
$cto :: forall x. Rep HydraNodeLog x -> HydraNodeLog
to :: forall x. Rep HydraNodeLog x -> HydraNodeLog
Generic)
  deriving anyclass ([HydraNodeLog] -> Value
[HydraNodeLog] -> Encoding
HydraNodeLog -> Bool
HydraNodeLog -> Value
HydraNodeLog -> Encoding
(HydraNodeLog -> Value)
-> (HydraNodeLog -> Encoding)
-> ([HydraNodeLog] -> Value)
-> ([HydraNodeLog] -> Encoding)
-> (HydraNodeLog -> Bool)
-> ToJSON HydraNodeLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: HydraNodeLog -> Value
toJSON :: HydraNodeLog -> Value
$ctoEncoding :: HydraNodeLog -> Encoding
toEncoding :: HydraNodeLog -> Encoding
$ctoJSONList :: [HydraNodeLog] -> Value
toJSONList :: [HydraNodeLog] -> Value
$ctoEncodingList :: [HydraNodeLog] -> Encoding
toEncodingList :: [HydraNodeLog] -> Encoding
$comitField :: HydraNodeLog -> Bool
omitField :: HydraNodeLog -> Bool
ToJSON)

data EndToEndLog
  = ClusterOptions {EndToEndLog -> Options
options :: Options}
  | FromCardanoNode NodeLog
  | FromFaucet FaucetLog
  | FromHydraNode HydraNodeLog
  | FromMithril MithrilLog
  | StartingFunds {EndToEndLog -> FilePath
actor :: String, EndToEndLog -> UTxO
utxo :: UTxO}
  | RefueledFunds {actor :: String, EndToEndLog -> Coin
refuelingAmount :: Coin, utxo :: UTxO}
  | RemainingFunds {actor :: String, utxo :: UTxO}
  | PublishedHydraScriptsAt {EndToEndLog -> [TxId]
hydraScriptsTxId :: [TxId]}
  | UsingHydraScriptsAt {hydraScriptsTxId :: [TxId]}
  | CreatedKey {EndToEndLog -> FilePath
keyPath :: FilePath}
  deriving stock (EndToEndLog -> EndToEndLog -> Bool
(EndToEndLog -> EndToEndLog -> Bool)
-> (EndToEndLog -> EndToEndLog -> Bool) -> Eq EndToEndLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EndToEndLog -> EndToEndLog -> Bool
== :: EndToEndLog -> EndToEndLog -> Bool
$c/= :: EndToEndLog -> EndToEndLog -> Bool
/= :: EndToEndLog -> EndToEndLog -> Bool
Eq, Int -> EndToEndLog -> ShowS
[EndToEndLog] -> ShowS
EndToEndLog -> FilePath
(Int -> EndToEndLog -> ShowS)
-> (EndToEndLog -> FilePath)
-> ([EndToEndLog] -> ShowS)
-> Show EndToEndLog
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EndToEndLog -> ShowS
showsPrec :: Int -> EndToEndLog -> ShowS
$cshow :: EndToEndLog -> FilePath
show :: EndToEndLog -> FilePath
$cshowList :: [EndToEndLog] -> ShowS
showList :: [EndToEndLog] -> ShowS
Show, (forall x. EndToEndLog -> Rep EndToEndLog x)
-> (forall x. Rep EndToEndLog x -> EndToEndLog)
-> Generic EndToEndLog
forall x. Rep EndToEndLog x -> EndToEndLog
forall x. EndToEndLog -> Rep EndToEndLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EndToEndLog -> Rep EndToEndLog x
from :: forall x. EndToEndLog -> Rep EndToEndLog x
$cto :: forall x. Rep EndToEndLog x -> EndToEndLog
to :: forall x. Rep EndToEndLog x -> EndToEndLog
Generic)
  deriving anyclass ([EndToEndLog] -> Value
[EndToEndLog] -> Encoding
EndToEndLog -> Bool
EndToEndLog -> Value
EndToEndLog -> Encoding
(EndToEndLog -> Value)
-> (EndToEndLog -> Encoding)
-> ([EndToEndLog] -> Value)
-> ([EndToEndLog] -> Encoding)
-> (EndToEndLog -> Bool)
-> ToJSON EndToEndLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: EndToEndLog -> Value
toJSON :: EndToEndLog -> Value
$ctoEncoding :: EndToEndLog -> Encoding
toEncoding :: EndToEndLog -> Encoding
$ctoJSONList :: [EndToEndLog] -> Value
toJSONList :: [EndToEndLog] -> Value
$ctoEncodingList :: [EndToEndLog] -> Encoding
toEncodingList :: [EndToEndLog] -> Encoding
$comitField :: EndToEndLog -> Bool
omitField :: EndToEndLog -> Bool
ToJSON)

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, NodeLog -> NominalDiffTime
timeDifference :: NominalDiffTime, NodeLog -> NominalDiffTime
blockTime :: NominalDiffTime, NodeLog -> NominalDiffTime
tipTime :: NominalDiffTime, NodeLog -> NominalDiffTime
targetTime :: NominalDiffTime}
  | 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)

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)

-- | 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
nodeDijkstraGenesisFile :: 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:nodeDijkstraGenesisFile:CardanoNodeArgs :: FilePath
nodeDijkstraGenesisFile = FilePath
"genesis-dijkstra.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
    }

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 -> Fixture.KnownNetwork -> IO (Maybe (NominalDiffTime, DirectOptions))
findRunningCardanoNode :: Tracer IO NodeLog
-> FilePath
-> KnownNetwork
-> IO (Maybe (NominalDiffTime, DirectOptions))
findRunningCardanoNode Tracer IO NodeLog
tracer FilePath
workDir KnownNetwork
knownNetwork = do
  Tracer IO NodeLog
-> NetworkId
-> SocketPath
-> IO (Maybe (NominalDiffTime, DirectOptions))
findRunningCardanoNode' Tracer IO NodeLog
tracer NetworkId
knownNetworkId SocketPath
socketPath
 where
  knownNetworkId :: NetworkId
knownNetworkId = KnownNetwork -> NetworkId
Fixture.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

-- | Tries to find an communicate with an existing cardano-node running in given
-- network id and socket path.
findRunningCardanoNode' :: Tracer IO NodeLog -> NetworkId -> SocketPath -> IO (Maybe (NominalDiffTime, DirectOptions))
findRunningCardanoNode' :: Tracer IO NodeLog
-> NetworkId
-> SocketPath
-> IO (Maybe (NominalDiffTime, DirectOptions))
findRunningCardanoNode' Tracer IO NodeLog
tracer NetworkId
networkId SocketPath
nodeSocket = do
  let opts :: DirectOptions
opts = DirectOptions{NetworkId
networkId :: NetworkId
$sel:networkId:DirectOptions :: NetworkId
networkId, SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:DirectOptions :: SocketPath
nodeSocket}
  IO NominalDiffTime -> IO (Either SomeException NominalDiffTime)
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 (DirectOptions
-> DirectBackend NominalDiffTime -> IO NominalDiffTime
forall a. DirectOptions -> DirectBackend a -> IO a
runDirectBackend DirectOptions
opts DirectBackend NominalDiffTime
forall (m :: * -> *). ChainBackend m => m NominalDiffTime
getBlockTime) IO (Either SomeException NominalDiffTime)
-> (Either SomeException NominalDiffTime
    -> IO (Maybe (NominalDiffTime, DirectOptions)))
-> IO (Maybe (NominalDiffTime, DirectOptions))
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 (NominalDiffTime, DirectOptions)
-> IO (Maybe (NominalDiffTime, DirectOptions))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe (NominalDiffTime, DirectOptions)
forall a. Maybe a
Nothing
    Right NominalDiffTime
blockTime ->
      Maybe (NominalDiffTime, DirectOptions)
-> IO (Maybe (NominalDiffTime, DirectOptions))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (NominalDiffTime, DirectOptions)
 -> IO (Maybe (NominalDiffTime, DirectOptions)))
-> Maybe (NominalDiffTime, DirectOptions)
-> IO (Maybe (NominalDiffTime, DirectOptions))
forall a b. (a -> b) -> a -> b
$ (NominalDiffTime, DirectOptions)
-> Maybe (NominalDiffTime, DirectOptions)
forall a. a -> Maybe a
Just (NominalDiffTime
blockTime, DirectOptions
opts)

-- | Run a backend action using the given 'ChainBackendOptions'.
runBackend :: ChainBackendOptions -> (forall m. (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) => m a) -> IO a
runBackend :: forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m a
action = case ChainBackendOptions
opts of
  Options.Direct DirectOptions
directOpts -> DirectOptions -> DirectBackend a -> IO a
forall a. DirectOptions -> DirectBackend a -> IO a
runDirectBackend DirectOptions
directOpts DirectBackend a
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m a
action
  Options.Blockfrost BlockfrostOptions
blockfrostOpts -> BlockfrostOptions -> BlockfrostBackend a -> IO a
forall a. BlockfrostOptions -> BlockfrostBackend a -> IO a
runBlockfrostBackend BlockfrostOptions
blockfrostOpts BlockfrostBackend a
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m a
action

-- | 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 ->
  (NominalDiffTime -> DirectOptions -> IO a) ->
  IO a
withCardanoNodeDevnet :: forall a.
Tracer IO NodeLog
-> FilePath -> (NominalDiffTime -> DirectOptions -> IO a) -> IO a
withCardanoNodeDevnet Tracer IO NodeLog
tracer FilePath
stateDirectory NominalDiffTime -> DirectOptions -> IO a
action = do
  CardanoNodeArgs
args <- FilePath -> IO CardanoNodeArgs
setupCardanoDevnet FilePath
stateDirectory
  -- Allocate a free port for the cardano-node P2P listener so concurrent
  -- devnets don't all try to bind 3001 (the cardano-node default). The port
  -- is reserved for this process for its whole lifetime, see
  -- 'Test.Network.Ports'.
  [Int
p] <- Int -> IO [Int]
Ports.randomUnusedTCPPorts Int
1
  Tracer IO NodeLog
-> FilePath
-> CardanoNodeArgs
-> (NominalDiffTime -> DirectOptions -> IO a)
-> IO a
forall a.
Tracer IO NodeLog
-> FilePath
-> CardanoNodeArgs
-> (NominalDiffTime -> DirectOptions -> IO a)
-> IO a
withCardanoNode Tracer IO NodeLog
tracer FilePath
stateDirectory CardanoNodeArgs
args{nodePort = Just p} NominalDiffTime -> DirectOptions -> IO a
action

withBlockfrostBackend ::
  Tracer IO EndToEndLog ->
  -- | State directory in which credentials, db & logs are persisted.
  FilePath ->
  (NominalDiffTime -> ChainBackendOptions -> IO a) ->
  IO a
withBlockfrostBackend :: forall a.
Tracer IO EndToEndLog
-> FilePath
-> (NominalDiffTime -> ChainBackendOptions -> IO a)
-> IO a
withBlockfrostBackend Tracer IO EndToEndLog
_tracer FilePath
stateDirectory NominalDiffTime -> ChainBackendOptions -> IO a
action = do
  CardanoNodeArgs
args <- FilePath -> IO CardanoNodeArgs
setupCardanoDevnet FilePath
stateDirectory
  Value
shelleyGenesis <- 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 (FilePath -> IO Value) -> FilePath -> IO Value
forall a b. (a -> b) -> a -> b
$ FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args
  FilePath
bfProjectPath <- Int -> FilePath -> IO FilePath
findFileStartingAtDirectory Int
3 FilePath
Backend.blockfrostProjectPath
  let opts :: ChainBackendOptions
opts = BlockfrostOptions -> ChainBackendOptions
Options.Blockfrost BlockfrostOptions
defaultBlockfrostOptions{projectPath = bfProjectPath}
  NominalDiffTime -> ChainBackendOptions -> IO a
action (Value -> NominalDiffTime
getShelleyGenesisBlockTime Value
shelleyGenesis) ChainBackendOptions
opts

-- | Find the given file in the current directory or its parents.
--
-- This function starts from the current working directory and checks if the specified file exists there.
-- If not found, it recursively checks the parent directories up to the given maximum depth.
findFileStartingAtDirectory :: Int -> FilePath -> IO FilePath
findFileStartingAtDirectory :: Int -> FilePath -> IO FilePath
findFileStartingAtDirectory Int
maxDepth FilePath
fileName = do
  FilePath
cwd <- IO FilePath
getCurrentDirectory
  Int -> FilePath -> IO FilePath
findInDir Int
maxDepth FilePath
cwd
 where
  findInDir :: Int -> FilePath -> IO FilePath
  findInDir :: Int -> FilePath -> IO FilePath
findInDir Int
depth FilePath
dir = do
    let path :: FilePath
path = FilePath
dir FilePath -> ShowS
</> FilePath
fileName
    Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
path
    if Bool
exists
      then FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
path
      else
        if Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
          then Text -> IO FilePath
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> IO FilePath) -> Text -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Text
"Could not locate the Blockfrost project file at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
pack FilePath
dir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" or " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
depth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" above."
          else do
            let parent :: FilePath
parent = FilePath
".." FilePath -> ShowS
</> ShowS
takeDirectory FilePath
dir
            if FilePath
parent FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
dir
              then Text -> IO FilePath
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Reached root directory without finding the Blockfrost project file."
              else Int -> FilePath -> IO FilePath
findInDir (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) FilePath
parent

withBackend ::
  forall a.
  Tracer IO EndToEndLog ->
  FilePath ->
  (NominalDiffTime -> ChainBackendOptions -> IO a) ->
  IO a
withBackend :: forall a.
Tracer IO EndToEndLog
-> FilePath
-> (NominalDiffTime -> ChainBackendOptions -> IO a)
-> IO a
withBackend Tracer IO EndToEndLog
tracer FilePath
stateDirectory NominalDiffTime -> ChainBackendOptions -> IO a
action = do
  IO HydraTestnet
getHydraNetwork IO HydraTestnet -> (HydraTestnet -> 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
    HydraTestnet
LocalDevnet -> Tracer IO NodeLog
-> FilePath -> (NominalDiffTime -> DirectOptions -> IO a) -> IO a
forall a.
Tracer IO NodeLog
-> FilePath -> (NominalDiffTime -> DirectOptions -> IO a) -> IO a
withCardanoNodeDevnet ((NodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO NodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap NodeLog -> EndToEndLog
FromCardanoNode Tracer IO EndToEndLog
tracer) FilePath
stateDirectory ((NominalDiffTime -> DirectOptions -> IO a) -> IO a)
-> (NominalDiffTime -> DirectOptions -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \NominalDiffTime
bt DirectOptions
opts -> NominalDiffTime -> ChainBackendOptions -> IO a
action NominalDiffTime
bt (DirectOptions -> ChainBackendOptions
Direct DirectOptions
opts)
    HydraTestnet
Preview -> KnownNetwork
-> (NominalDiffTime -> ChainBackendOptions -> IO a) -> IO a
withNode KnownNetwork
Fixture.Preview NominalDiffTime -> ChainBackendOptions -> IO a
action
    HydraTestnet
Preproduction -> KnownNetwork
-> (NominalDiffTime -> ChainBackendOptions -> IO a) -> IO a
withNode KnownNetwork
Fixture.Preproduction NominalDiffTime -> ChainBackendOptions -> IO a
action
    HydraTestnet
Mainnet -> KnownNetwork
-> (NominalDiffTime -> ChainBackendOptions -> IO a) -> IO a
withNode KnownNetwork
Fixture.Mainnet NominalDiffTime -> ChainBackendOptions -> IO a
action
    HydraTestnet
TestPrelude.Blockfrost -> Tracer IO EndToEndLog
-> FilePath
-> (NominalDiffTime -> ChainBackendOptions -> IO a)
-> IO a
forall a.
Tracer IO EndToEndLog
-> FilePath
-> (NominalDiffTime -> ChainBackendOptions -> IO a)
-> IO a
withBlockfrostBackend Tracer IO EndToEndLog
tracer FilePath
stateDirectory NominalDiffTime -> ChainBackendOptions -> IO a
action
 where
  withNode :: KnownNetwork
-> (NominalDiffTime -> ChainBackendOptions -> IO a) -> IO a
withNode KnownNetwork
network NominalDiffTime -> ChainBackendOptions -> IO a
action' = do
    FilePath
nodeDir <- FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
stateDirectory (Maybe FilePath -> FilePath) -> IO (Maybe FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
lookupEnv FilePath
"HYDRA_WORK_DIR"
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
nodeDir
    let syncAndRun :: NominalDiffTime -> DirectOptions -> IO a
syncAndRun NominalDiffTime
blockTime DirectOptions
opts = do
          Tracer IO NodeLog -> ChainBackendOptions -> IO ()
waitForFullySynchronized ((NodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO NodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap NodeLog -> EndToEndLog
FromCardanoNode Tracer IO EndToEndLog
tracer) (DirectOptions -> ChainBackendOptions
Direct DirectOptions
opts)
          NominalDiffTime -> ChainBackendOptions -> IO a
action' NominalDiffTime
blockTime (DirectOptions -> ChainBackendOptions
Direct DirectOptions
opts)
    Tracer IO NodeLog
-> FilePath
-> KnownNetwork
-> IO (Maybe (NominalDiffTime, DirectOptions))
findRunningCardanoNode ((NodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO NodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap NodeLog -> EndToEndLog
FromCardanoNode Tracer IO EndToEndLog
tracer) FilePath
nodeDir KnownNetwork
network IO (Maybe (NominalDiffTime, DirectOptions))
-> (Maybe (NominalDiffTime, DirectOptions) -> 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
      Just (NominalDiffTime
blockTime, DirectOptions
opts) ->
        NominalDiffTime -> DirectOptions -> IO a
syncAndRun NominalDiffTime
blockTime DirectOptions
opts
      Maybe (NominalDiffTime, DirectOptions)
Nothing -> do
        let dbDir :: FilePath
dbDir = FilePath
nodeDir FilePath -> ShowS
</> FilePath
"db"
        Bool
dbExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
dbDir
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dbExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Tracer IO MithrilLog -> KnownNetwork -> FilePath -> IO ()
downloadLatestSnapshotTo ((MithrilLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO MithrilLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap MithrilLog -> EndToEndLog
FromMithril Tracer IO EndToEndLog
tracer) KnownNetwork
network FilePath
nodeDir
        Tracer IO NodeLog
-> FilePath
-> KnownNetwork
-> (NominalDiffTime -> DirectOptions -> IO a)
-> IO a
forall a.
Tracer IO NodeLog
-> FilePath
-> KnownNetwork
-> (NominalDiffTime -> DirectOptions -> IO a)
-> IO a
withCardanoNodeOnKnownNetwork ((NodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO NodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap NodeLog -> EndToEndLog
FromCardanoNode Tracer IO EndToEndLog
tracer) FilePath
nodeDir KnownNetwork
network NominalDiffTime -> DirectOptions -> IO a
syncAndRun

-- | Like 'withBackend', but also publishes (or reuses cached) Hydra scripts.
-- On public testnets the cache file is stored in the persistent 'HYDRA_WORK_DIR',
-- so scripts are published once and reused across test runs. On local devnet,
-- the per-test 'stateDirectory' is used, so scripts are always published fresh.
withHydraScriptsAndBackendRunning ::
  forall a.
  Tracer IO EndToEndLog ->
  FilePath ->
  (ChainBackendOptions -> [TxId] -> IO a) ->
  IO a
withHydraScriptsAndBackendRunning :: forall a.
Tracer IO EndToEndLog
-> FilePath -> (ChainBackendOptions -> [TxId] -> IO a) -> IO a
withHydraScriptsAndBackendRunning Tracer IO EndToEndLog
tracer FilePath
stateDirectory ChainBackendOptions -> [TxId] -> IO a
action = do
  IO HydraTestnet
getHydraNetwork IO HydraTestnet -> (HydraTestnet -> 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
    HydraTestnet
LocalDevnet -> Tracer IO NodeLog
-> FilePath -> (NominalDiffTime -> DirectOptions -> IO a) -> IO a
forall a.
Tracer IO NodeLog
-> FilePath -> (NominalDiffTime -> DirectOptions -> IO a) -> IO a
withCardanoNodeDevnet ((NodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO NodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap NodeLog -> EndToEndLog
FromCardanoNode Tracer IO EndToEndLog
tracer) FilePath
stateDirectory ((NominalDiffTime -> DirectOptions -> IO a) -> IO a)
-> (NominalDiffTime -> DirectOptions -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \NominalDiffTime
_ DirectOptions
opts -> do
      [TxId]
txIds <- ChainBackendOptions -> Actor -> FilePath -> IO [TxId]
publishOrReuseHydraScripts (DirectOptions -> ChainBackendOptions
Direct DirectOptions
opts) Actor
Fixture.Faucet FilePath
stateDirectory
      ChainBackendOptions -> [TxId] -> IO a
action (DirectOptions -> ChainBackendOptions
Direct DirectOptions
opts) [TxId]
txIds
    HydraTestnet
Preview -> KnownNetwork -> IO a
withPublicTestnetNode KnownNetwork
Fixture.Preview
    HydraTestnet
Preproduction -> KnownNetwork -> IO a
withPublicTestnetNode KnownNetwork
Fixture.Preproduction
    HydraTestnet
Mainnet -> KnownNetwork -> IO a
withPublicTestnetNode KnownNetwork
Fixture.Mainnet
    HydraTestnet
TestPrelude.Blockfrost -> Tracer IO EndToEndLog
-> FilePath
-> (NominalDiffTime -> ChainBackendOptions -> IO a)
-> IO a
forall a.
Tracer IO EndToEndLog
-> FilePath
-> (NominalDiffTime -> ChainBackendOptions -> IO a)
-> IO a
withBlockfrostBackend Tracer IO EndToEndLog
tracer FilePath
stateDirectory ((NominalDiffTime -> ChainBackendOptions -> IO a) -> IO a)
-> (NominalDiffTime -> ChainBackendOptions -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \NominalDiffTime
_ ChainBackendOptions
opts -> do
      [TxId]
txIds <- ChainBackendOptions -> Actor -> FilePath -> IO [TxId]
publishOrReuseHydraScripts ChainBackendOptions
opts Actor
Fixture.Faucet FilePath
stateDirectory
      ChainBackendOptions -> [TxId] -> IO a
action ChainBackendOptions
opts [TxId]
txIds
 where
  withPublicTestnetNode :: KnownNetwork -> IO a
withPublicTestnetNode KnownNetwork
network = do
    FilePath
nodeDir <- FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
stateDirectory (Maybe FilePath -> FilePath) -> IO (Maybe FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
lookupEnv FilePath
"HYDRA_WORK_DIR"
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
nodeDir
    let syncPublishAndRun :: NominalDiffTime -> DirectOptions -> IO a
syncPublishAndRun NominalDiffTime
_ DirectOptions
opts = do
          Tracer IO NodeLog -> ChainBackendOptions -> IO ()
waitForFullySynchronized ((NodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO NodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap NodeLog -> EndToEndLog
FromCardanoNode Tracer IO EndToEndLog
tracer) (DirectOptions -> ChainBackendOptions
Direct DirectOptions
opts)
          [TxId]
txIds <- ChainBackendOptions -> Actor -> FilePath -> IO [TxId]
publishOrReuseHydraScripts (DirectOptions -> ChainBackendOptions
Direct DirectOptions
opts) Actor
Fixture.Faucet FilePath
nodeDir
          ChainBackendOptions -> [TxId] -> IO a
action (DirectOptions -> ChainBackendOptions
Direct DirectOptions
opts) [TxId]
txIds
    Tracer IO NodeLog
-> FilePath
-> KnownNetwork
-> IO (Maybe (NominalDiffTime, DirectOptions))
findRunningCardanoNode ((NodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO NodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap NodeLog -> EndToEndLog
FromCardanoNode Tracer IO EndToEndLog
tracer) FilePath
nodeDir KnownNetwork
network IO (Maybe (NominalDiffTime, DirectOptions))
-> (Maybe (NominalDiffTime, DirectOptions) -> 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
      Just (NominalDiffTime
blockTime, DirectOptions
opts) ->
        NominalDiffTime -> DirectOptions -> IO a
syncPublishAndRun NominalDiffTime
blockTime DirectOptions
opts
      Maybe (NominalDiffTime, DirectOptions)
Nothing -> do
        let dbDir :: FilePath
dbDir = FilePath
nodeDir FilePath -> ShowS
</> FilePath
"db"
        Bool
dbExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
dbDir
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dbExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Tracer IO MithrilLog -> KnownNetwork -> FilePath -> IO ()
downloadLatestSnapshotTo ((MithrilLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO MithrilLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap MithrilLog -> EndToEndLog
FromMithril Tracer IO EndToEndLog
tracer) KnownNetwork
network FilePath
nodeDir
        Tracer IO NodeLog
-> FilePath
-> KnownNetwork
-> (NominalDiffTime -> DirectOptions -> IO a)
-> IO a
forall a.
Tracer IO NodeLog
-> FilePath
-> KnownNetwork
-> (NominalDiffTime -> DirectOptions -> IO a)
-> IO a
withCardanoNodeOnKnownNetwork ((NodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO NodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap NodeLog -> EndToEndLog
FromCardanoNode Tracer IO EndToEndLog
tracer) FilePath
nodeDir KnownNetwork
network NominalDiffTime -> DirectOptions -> IO a
syncPublishAndRun

-- | 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.
  Fixture.KnownNetwork ->
  (NominalDiffTime -> DirectOptions -> IO a) ->
  IO a
withCardanoNodeOnKnownNetwork :: forall a.
Tracer IO NodeLog
-> FilePath
-> KnownNetwork
-> (NominalDiffTime -> DirectOptions -> IO a)
-> IO a
withCardanoNodeOnKnownNetwork Tracer IO NodeLog
tracer FilePath
stateDirectory KnownNetwork
knownNetwork NominalDiffTime -> DirectOptions -> IO a
action = do
  IO ()
copyKnownNetworkFiles
  Tracer IO NodeLog
-> FilePath
-> CardanoNodeArgs
-> (NominalDiffTime -> DirectOptions -> IO a)
-> IO a
forall a.
Tracer IO NodeLog
-> FilePath
-> CardanoNodeArgs
-> (NominalDiffTime -> DirectOptions -> IO a)
-> IO a
withCardanoNode Tracer IO NodeLog
tracer FilePath
stateDirectory CardanoNodeArgs
args NominalDiffTime -> DirectOptions -> 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"
      , nodeDijkstraGenesisFile = "dijkstra-genesis.json"
      }

  -- Copy/download configuration files for a known network
  copyKnownNetworkFiles :: IO ()
copyKnownNetworkFiles = do
    [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
"peer-snapshot.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
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)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KnownNetwork
knownNetwork KnownNetwork -> [KnownNetwork] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [KnownNetwork
Fixture.Mainnet, KnownNetwork
Fixture.Preview]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath
"checkpoints.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
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"

  -- Network name on remote
  knownNetworkName :: FilePath
knownNetworkName = case KnownNetwork
knownNetwork of
    KnownNetwork
Fixture.Preview -> FilePath
"environments/preview"
    KnownNetwork
Fixture.Preproduction -> FilePath
"environments/preprod"
    KnownNetwork
Fixture.Mainnet -> FilePath
"environments/mainnet"
    -- NOTE: Here we map blockfrost networks to cardano ones since we expect to find actor keys
    -- in known locations when running smoke-tests.
    KnownNetwork
Fixture.BlockfrostPreview -> FilePath
"environments/preview"
    KnownNetwork
Fixture.BlockfrostPreprod -> FilePath
"environments/preprod"
    KnownNetwork
Fixture.BlockfrostMainnet -> FilePath
"environments/mainnet"

  fetchConfigFile :: String -> IO ByteString
  fetchConfigFile :: FilePath -> IO ByteString
fetchConfigFile FilePath
path =
    FilePath -> IO Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequestThrow FilePath
path IO Request
-> (Request -> IO (Response ByteString))
-> IO (Response ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpBS IO (Response ByteString)
-> (Response ByteString -> ByteString) -> IO 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)
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-dijkstra.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
nodeDijkstraGenesisFile 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

withCardanoNode ::
  Tracer IO NodeLog ->
  FilePath ->
  CardanoNodeArgs ->
  (NominalDiffTime -> DirectOptions -> IO a) ->
  IO a
withCardanoNode :: forall a.
Tracer IO NodeLog
-> FilePath
-> CardanoNodeArgs
-> (NominalDiffTime -> DirectOptions -> IO a)
-> IO a
withCardanoNode Tracer IO NodeLog
tr FilePath
stateDirectory CardanoNodeArgs
args NominalDiffTime -> DirectOptions -> 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, close_fds = True} ((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` (ProcessHandle -> IO ()
stopNode ProcessHandle
processHandle IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
cleanupSocketFile)) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
          (FilePath, IO Void) -> (FilePath, IO a) -> IO (Either Void a)
forall (m :: * -> *) a b.
MonadAsync m =>
(FilePath, m a) -> (FilePath, m b) -> m (Either a b)
raceLabelled
            (FilePath
"check-cardano-node-process-not-died", Text -> ProcessHandle -> Maybe Handle -> IO Void
checkProcessHasNotDied Text
"cardano-node" ProcessHandle
processHandle Maybe Handle
mError)
            (FilePath
"wait-for-node", IO a
waitForNode)
            IO (Either Void a) -> (Either Void a -> a) -> IO a
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Void -> a) -> (a -> a) -> Either Void a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Void -> a
forall a. Void -> a
absurd a -> a
forall a. a -> a
id
 where
  -- Stop the node synchronously: 'withCreateProcess's own cleanup delivers
  -- SIGTERM but reaps in a forked thread, so without this the node can still
  -- be flushing its database (e.g. writing db/clean) while an enclosing
  -- 'withTempDir' already removes the directory.
  stopNode :: ProcessHandle -> IO ()
stopNode ProcessHandle
processHandle = do
    ProcessHandle -> IO ()
terminateProcess ProcessHandle
processHandle
    IO (Maybe ExitCode) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ExitCode) -> IO ()) -> IO (Maybe ExitCode) -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ExitCode -> IO (Maybe ExitCode)
forall a. DiffTime -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
10 (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processHandle)

  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
    NominalDiffTime -> DirectOptions -> IO a
action (Value -> NominalDiffTime
getShelleyGenesisBlockTime Value
shelleyGenesis) DirectOptions{$sel:networkId:DirectOptions :: NetworkId
networkId = Value -> NetworkId
getShelleyGenesisNetworkId Value
shelleyGenesis, $sel:nodeSocket:DirectOptions :: SocketPath
nodeSocket = FilePath -> SocketPath
forall content (direction :: FileDirection).
FilePath -> File content direction
File (FilePath
stateDirectory FilePath -> ShowS
</> FilePath
nodeSocket)}

  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)

-- | Wait until the node is fully caught up with the network. This can take a
-- while!
waitForFullySynchronized ::
  Tracer IO NodeLog ->
  ChainBackendOptions ->
  IO ()
waitForFullySynchronized :: Tracer IO NodeLog -> ChainBackendOptions -> IO ()
waitForFullySynchronized Tracer IO NodeLog
tracer ChainBackendOptions
opts = do
  SystemStart
systemStart <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m SystemStart)
-> IO SystemStart
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m SystemStart)
 -> IO SystemStart)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m SystemStart)
-> IO SystemStart
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m SystemStart
forall (m :: * -> *). ChainBackend m => QueryPoint -> m SystemStart
querySystemStart 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 <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m EraHistory)
-> IO EraHistory
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m EraHistory)
 -> IO EraHistory)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m EraHistory)
-> IO EraHistory
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m EraHistory
forall (m :: * -> *). ChainBackend m => QueryPoint -> m EraHistory
queryEraHistory QueryPoint
QueryTip
    SlotNo
tipSlotNo <- SlotNo -> Maybe SlotNo -> SlotNo
forall a. a -> Maybe a -> a
fromMaybe SlotNo
0 (Maybe SlotNo -> SlotNo)
-> (ChainPoint -> Maybe SlotNo) -> ChainPoint -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainPoint -> Maybe SlotNo
Api.chainPointToSlotNo (ChainPoint -> SlotNo) -> IO ChainPoint -> IO SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ChainPoint)
-> IO ChainPoint
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m ChainPoint
forall (m :: * -> *). ChainBackend m => m ChainPoint
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m ChainPoint
queryTip
    (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)
    NominalDiffTime
blockTime <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NominalDiffTime)
-> IO NominalDiffTime
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NominalDiffTime
forall (m :: * -> *). ChainBackend m => m NominalDiffTime
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NominalDiffTime
getBlockTime
    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, NominalDiffTime
$sel:blockTime:MsgNodeCmdSpec :: NominalDiffTime
blockTime :: NominalDiffTime
blockTime, $sel:tipTime:MsgNodeCmdSpec :: NominalDiffTime
tipTime = RelativeTime -> NominalDiffTime
getRelativeTime RelativeTime
tipTime, $sel:targetTime:MsgNodeCmdSpec :: NominalDiffTime
targetTime = RelativeTime -> NominalDiffTime
getRelativeTime RelativeTime
targetTime, NominalDiffTime
$sel:timeDifference:MsgNodeCmdSpec :: NominalDiffTime
timeDifference :: NominalDiffTime
timeDifference}
    if NominalDiffTime
timeDifference NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* 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 =
  let bootstrapPeers :: [Value]
bootstrapPeers = (Int -> Value) -> [Int] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Value
encodePeer [Int]
peers
   in [Pair] -> Value
Aeson.object
        [ Key
"bootstrapPeers"
            Key -> Maybe [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= if [Value] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
bootstrapPeers
              then Maybe [Value]
forall a. Maybe a
Nothing
              else [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
bootstrapPeers
        , Key
"localRoots"
            Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Array -> Value
Aeson.Array
              ( [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList
                  [ [Pair] -> Value
Aeson.object
                      [ Key
"accessPoints" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
Aeson.emptyArray
                      , Key
"advertise" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False
                      , Key
"trustable" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False
                      , Key
"valency" Key -> Natural -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Natural
1 :: Natural)
                      ]
                  ]
              )
        , Key
"publicRoots"
            Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Array -> Value
Aeson.Array
              ( [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList
                  [ [Pair] -> Value
Aeson.object
                      [ Key
"accessPoints" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
Aeson.emptyArray
                      , Key
"advertise" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False
                      ]
                  ]
              )
        , Key
"peerSnapshotFile" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
Aeson.Null
        ]
 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)]

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)

-- | 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
"conway"
    , 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
--

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