{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TypeApplications   #-}
{-# OPTIONS_GHC -Wno-partial-fields #-}
{-| Startup cardano nodes programmatically
-}
module Convex.Devnet.CardanoNode(
  NodeId(..),
  NodeLog(..),
  RunningNode(..),
  DevnetConfig(..),
  CardanoNodeArgs(..),
  defaultCardanoNodeArgs,
  withCardanoNode,
  getCardanoNodeVersion,
  waitForFullySynchronized,
  waitForBlock,
  waitForSocket,
  withCardanoNodeDevnet,
  GenesisConfigChanges(..),
  allowLargeTransactions,
  withCardanoNodeDevnetConfig
) where

import           Cardano.Api                      (CardanoMode, Env,
                                                   LocalNodeConnectInfo,
                                                   NetworkId)
import qualified Cardano.Api                      as C
import           Cardano.Ledger.Alonzo.Genesis    (AlonzoGenesis)
import           Cardano.Ledger.Conway.Genesis    (ConwayGenesis)
import qualified Cardano.Ledger.Core              as Core
import           Cardano.Ledger.Shelley.Genesis   (ShelleyGenesis (..))
import           Cardano.Slotting.Slot            (withOriginToMaybe)
import           Cardano.Slotting.Time            (diffRelativeTime,
                                                   getRelativeTime,
                                                   toRelativeTime)
import           Control.Concurrent               (threadDelay)
import           Control.Concurrent.Async         (race)
import           Control.Exception                (finally, throwIO)
import           Control.Lens                     (over)
import           Control.Monad                    (unless, when, (>=>))
import           Control.Monad.Except             (runExceptT)
import           Control.Tracer                   (Tracer, traceWith)
import qualified Convex.Devnet.NodeQueries        as Q
import           Convex.Devnet.Utils              (checkProcessHasNotDied,
                                                   defaultNetworkId, failure,
                                                   readConfigFile, withLogFile)
import           Data.Aeson                       (FromJSON, ToJSON (toJSON),
                                                   (.=))
import qualified Data.Aeson                       as Aeson
import qualified Data.Aeson.KeyMap                as Aeson.KeyMap
import qualified Data.ByteString                  as BS
import           Data.Fixed                       (Centi)
import           Data.Functor                     ((<&>))
import           Data.Text                        (Text)
import qualified Data.Text                        as Text
import           Data.Time.Clock                  (UTCTime, addUTCTime,
                                                   getCurrentTime)
import           Data.Time.Clock.POSIX            (posixSecondsToUTCTime,
                                                   utcTimeToPOSIXSeconds)
import           GHC.Generics                     (Generic)
import           Ouroboros.Consensus.Shelley.Eras (ShelleyEra, StandardCrypto)
import           System.Directory                 (createDirectoryIfMissing,
                                                   doesFileExist, removeFile)
import           System.FilePath                  ((</>))
import           System.IO                        (BufferMode (NoBuffering),
                                                   hSetBuffering)
import           System.Posix                     (ownerReadMode, setFileMode)
import           System.Process                   (CreateProcess (..),
                                                   StdStream (UseHandle), proc,
                                                   readProcess,
                                                   withCreateProcess)

import           Prelude

type Port = Int

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

data RunningNode = RunningNode
  { RunningNode -> FilePath
rnNodeSocket     :: FilePath -- ^ Cardano node socket
  , RunningNode -> NetworkId
rnNetworkId      :: NetworkId -- ^ Network ID used by the cardano node
  , RunningNode -> FilePath
rnNodeConfigFile :: FilePath -- ^ Cardano node config file (JSON)
  , RunningNode -> (LocalNodeConnectInfo CardanoMode, Env)
rnConnectInfo    :: (LocalNodeConnectInfo CardanoMode, Env) -- ^ Connection info for node queries
  }

-- | Configuration parameters for a single node devnet
data DevnetConfig = DevnetConfig
  { -- | Parent state directory
    DevnetConfig -> FilePath
dcStateDirectory :: FilePath
  , -- | Blockchain start time
    DevnetConfig -> UTCTime
dcSystemStart    :: UTCTime
  , -- | A list of port
    DevnetConfig -> PortsConfig
dcPorts          :: PortsConfig
  }
  deriving stock (DevnetConfig -> DevnetConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DevnetConfig -> DevnetConfig -> Bool
$c/= :: DevnetConfig -> DevnetConfig -> Bool
== :: DevnetConfig -> DevnetConfig -> Bool
$c== :: DevnetConfig -> DevnetConfig -> Bool
Eq, Int -> DevnetConfig -> ShowS
[DevnetConfig] -> ShowS
DevnetConfig -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DevnetConfig] -> ShowS
$cshowList :: [DevnetConfig] -> ShowS
show :: DevnetConfig -> FilePath
$cshow :: DevnetConfig -> FilePath
showsPrec :: Int -> DevnetConfig -> ShowS
$cshowsPrec :: Int -> DevnetConfig -> ShowS
Show, 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
$cto :: forall x. Rep DevnetConfig x -> DevnetConfig
$cfrom :: forall x. DevnetConfig -> Rep DevnetConfig x
Generic)
  deriving anyclass ([DevnetConfig] -> Encoding
[DevnetConfig] -> Value
DevnetConfig -> Encoding
DevnetConfig -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [DevnetConfig] -> Encoding
$ctoEncodingList :: [DevnetConfig] -> Encoding
toJSONList :: [DevnetConfig] -> Value
$ctoJSONList :: [DevnetConfig] -> Value
toEncoding :: DevnetConfig -> Encoding
$ctoEncoding :: DevnetConfig -> Encoding
toJSON :: DevnetConfig -> Value
$ctoJSON :: DevnetConfig -> Value
ToJSON, Value -> Parser [DevnetConfig]
Value -> Parser DevnetConfig
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [DevnetConfig]
$cparseJSONList :: Value -> Parser [DevnetConfig]
parseJSON :: Value -> Parser DevnetConfig
$cparseJSON :: Value -> Parser 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
    { nodeSocket :: FilePath
nodeSocket = FilePath
"node.socket"
    , nodeConfigFile :: FilePath
nodeConfigFile = FilePath
"configuration.json"
    , nodeByronGenesisFile :: FilePath
nodeByronGenesisFile = FilePath
"genesis-byron.json"
    , nodeShelleyGenesisFile :: FilePath
nodeShelleyGenesisFile = FilePath
"genesis-shelley.json"
    , nodeAlonzoGenesisFile :: FilePath
nodeAlonzoGenesisFile = FilePath
"genesis-alonzo.json"
    , nodeConwayGenesisFile :: FilePath
nodeConwayGenesisFile = FilePath
"genesis-conway.json"
    , nodeTopologyFile :: FilePath
nodeTopologyFile = FilePath
"topology.json"
    , nodeDatabaseDir :: FilePath
nodeDatabaseDir = FilePath
"db"
    , nodeDlgCertFile :: Maybe FilePath
nodeDlgCertFile = forall a. Maybe a
Nothing
    , nodeSignKeyFile :: Maybe FilePath
nodeSignKeyFile = forall a. Maybe a
Nothing
    , nodeOpCertFile :: Maybe FilePath
nodeOpCertFile = forall a. Maybe a
Nothing
    , nodeKesKeyFile :: Maybe FilePath
nodeKesKeyFile = forall a. Maybe a
Nothing
    , nodeVrfKeyFile :: Maybe FilePath
nodeVrfKeyFile = forall a. Maybe a
Nothing
    , nodePort :: Maybe Int
nodePort = 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
  { -- | Our node TCP port.
    PortsConfig -> Int
ours  :: Port
  , -- | Other peers TCP ports.
    PortsConfig -> [Int]
peers :: [Port]
  }
  deriving stock (Int -> PortsConfig -> ShowS
[PortsConfig] -> ShowS
PortsConfig -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PortsConfig] -> ShowS
$cshowList :: [PortsConfig] -> ShowS
show :: PortsConfig -> FilePath
$cshow :: PortsConfig -> FilePath
showsPrec :: Int -> PortsConfig -> ShowS
$cshowsPrec :: Int -> PortsConfig -> ShowS
Show, PortsConfig -> PortsConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PortsConfig -> PortsConfig -> Bool
$c/= :: PortsConfig -> PortsConfig -> Bool
== :: PortsConfig -> PortsConfig -> Bool
$c== :: PortsConfig -> PortsConfig -> Bool
Eq, 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
$cto :: forall x. Rep PortsConfig x -> PortsConfig
$cfrom :: forall x. PortsConfig -> Rep PortsConfig x
Generic)
  deriving anyclass ([PortsConfig] -> Encoding
[PortsConfig] -> Value
PortsConfig -> Encoding
PortsConfig -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [PortsConfig] -> Encoding
$ctoEncodingList :: [PortsConfig] -> Encoding
toJSONList :: [PortsConfig] -> Value
$ctoJSONList :: [PortsConfig] -> Value
toEncoding :: PortsConfig -> Encoding
$ctoEncoding :: PortsConfig -> Encoding
toJSON :: PortsConfig -> Value
$ctoJSON :: PortsConfig -> Value
ToJSON, Value -> Parser [PortsConfig]
Value -> Parser PortsConfig
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PortsConfig]
$cparseJSONList :: Value -> Parser [PortsConfig]
parseJSON :: Value -> Parser PortsConfig
$cparseJSON :: Value -> Parser PortsConfig
FromJSON)

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

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

withCardanoNode ::
  Tracer IO NodeLog ->
  NetworkId ->
  FilePath ->
  CardanoNodeArgs ->
  (RunningNode -> IO a) ->
  IO a
withCardanoNode :: forall a.
Tracer IO NodeLog
-> NetworkId
-> FilePath
-> CardanoNodeArgs
-> (RunningNode -> IO a)
-> IO a
withCardanoNode Tracer IO NodeLog
tr NetworkId
networkId FilePath
stateDirectory args :: CardanoNodeArgs
args@CardanoNodeArgs{FilePath
nodeSocket :: FilePath
nodeSocket :: CardanoNodeArgs -> FilePath
nodeSocket, FilePath
nodeConfigFile :: FilePath
nodeConfigFile :: CardanoNodeArgs -> FilePath
nodeConfigFile} RunningNode -> IO a
action = do
  forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tr forall a b. (a -> b) -> a -> b
$ Text -> NodeLog
MsgNodeCmdSpec (FilePath -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ CreateProcess -> CmdSpec
cmdspec CreateProcess
process)
  forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tr forall a b. (a -> b) -> a -> b
$ MsgNodeStarting{FilePath
stateDirectory :: FilePath
stateDirectory :: FilePath
stateDirectory}
  forall a. FilePath -> (Handle -> IO a) -> IO a
withLogFile FilePath
logFilePath forall a b. (a -> b) -> a -> b
$ \Handle
out -> do
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
out BufferMode
NoBuffering
    forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
process{std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
out, std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
out} forall a b. (a -> b) -> a -> b
$
      \Maybe Handle
_stdin Maybe Handle
_stdout Maybe Handle
_stderr ProcessHandle
processHandle -> do
        forall a b. IO a -> IO b -> IO (Either a b)
race
          (Text -> ProcessHandle -> IO Void
checkProcessHasNotDied Text
"cardano-node" ProcessHandle
processHandle)
          IO a
waitForNode
          forall a b. IO a -> IO b -> IO a
`finally` IO ()
cleanupSocketFile forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left Void
_    -> forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure FilePath
"withCardanoNode: unexpected termination"
          Right a
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

 where
  process :: CreateProcess
process = Maybe FilePath -> CardanoNodeArgs -> CreateProcess
cardanoNodeProcess (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
    FilePath -> IO ()
waitForFile FilePath
socketPath
    let rnNodeConfigFile :: FilePath
rnNodeConfigFile = FilePath
stateDirectory FilePath -> ShowS
</> FilePath
nodeConfigFile
    forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tr forall a b. (a -> b) -> a -> b
$ FilePath -> NodeLog
MsgSocketIsReady FilePath
socketPath
    (LocalNodeConnectInfo CardanoMode, Env)
rnConnectInfo <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall (m :: * -> *).
(MonadError InitialLedgerStateError m, MonadIO m) =>
FilePath -> FilePath -> m (LocalNodeConnectInfo CardanoMode, Env)
Q.loadConnectInfo FilePath
rnNodeConfigFile FilePath
socketPath) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => FilePath -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Semigroup a => a -> a -> a
(<>) FilePath
"Failed to load connect info: " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitialLedgerStateError -> Text
C.renderInitialLedgerStateError) forall (f :: * -> *) a. Applicative f => a -> f a
pure
    let rn :: RunningNode
rn = RunningNode{rnNodeSocket :: FilePath
rnNodeSocket = FilePath
socketPath, rnNetworkId :: NetworkId
rnNetworkId = NetworkId
networkId, FilePath
rnNodeConfigFile :: FilePath
rnNodeConfigFile :: FilePath
rnNodeConfigFile, (LocalNodeConnectInfo CardanoMode, Env)
rnConnectInfo :: (LocalNodeConnectInfo CardanoMode, Env)
rnConnectInfo :: (LocalNodeConnectInfo CardanoMode, Env)
rnConnectInfo}
    RunningNode -> IO a
action RunningNode
rn

  cleanupSocketFile :: IO ()
cleanupSocketFile = do
    Bool
x <- FilePath -> IO Bool
doesFileExist FilePath
socketPath
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
x (FilePath -> IO ()
removeFile FilePath
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){Maybe FilePath
cwd :: Maybe FilePath
cwd :: Maybe FilePath
cwd}
 where
  CardanoNodeArgs
    { FilePath
nodeConfigFile :: FilePath
nodeConfigFile :: CardanoNodeArgs -> FilePath
nodeConfigFile
    , FilePath
nodeTopologyFile :: FilePath
nodeTopologyFile :: CardanoNodeArgs -> FilePath
nodeTopologyFile
    , FilePath
nodeDatabaseDir :: FilePath
nodeDatabaseDir :: CardanoNodeArgs -> FilePath
nodeDatabaseDir
    , FilePath
nodeSocket :: FilePath
nodeSocket :: CardanoNodeArgs -> FilePath
nodeSocket
    , Maybe Int
nodePort :: Maybe Int
nodePort :: CardanoNodeArgs -> Maybe Int
nodePort
    , Maybe FilePath
nodeSignKeyFile :: Maybe FilePath
nodeSignKeyFile :: CardanoNodeArgs -> Maybe FilePath
nodeSignKeyFile
    , Maybe FilePath
nodeDlgCertFile :: Maybe FilePath
nodeDlgCertFile :: CardanoNodeArgs -> Maybe FilePath
nodeDlgCertFile
    , Maybe FilePath
nodeOpCertFile :: Maybe FilePath
nodeOpCertFile :: CardanoNodeArgs -> Maybe FilePath
nodeOpCertFile
    , Maybe FilePath
nodeKesKeyFile :: Maybe FilePath
nodeKesKeyFile :: CardanoNodeArgs -> Maybe FilePath
nodeKesKeyFile
    , Maybe FilePath
nodeVrfKeyFile :: Maybe FilePath
nodeVrfKeyFile :: CardanoNodeArgs -> Maybe FilePath
nodeVrfKeyFile
    } = CardanoNodeArgs
args

  strArgs :: [FilePath]
strArgs =
    FilePath
"run" forall a. a -> [a] -> [a]
:
    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]
      , forall a. a -> Maybe a -> [a]
opt FilePath
"--port" (forall a. Show a => a -> FilePath
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
nodePort)
      , forall a. a -> Maybe a -> [a]
opt FilePath
"--byron-signing-key" Maybe FilePath
nodeSignKeyFile
      , forall a. a -> Maybe a -> [a]
opt FilePath
"--byron-delegation-certificate" Maybe FilePath
nodeDlgCertFile
      , forall a. a -> Maybe a -> [a]
opt FilePath
"--shelley-operational-certificate" Maybe FilePath
nodeOpCertFile
      , forall a. a -> Maybe a -> [a]
opt FilePath
"--shelley-kes-key" Maybe FilePath
nodeKesKeyFile
      , 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]

-- | Wait for the node socket file to become available.
waitForSocket :: RunningNode -> IO ()
waitForSocket :: RunningNode -> IO ()
waitForSocket = FilePath -> IO ()
waitForFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunningNode -> FilePath
rnNodeSocket

-- | Wait until a file exists
waitForFile :: FilePath -> IO ()
waitForFile :: FilePath -> IO ()
waitForFile FilePath
fp = do
  Bool
x <- FilePath -> IO Bool
doesFileExist FilePath
fp
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
x forall a b. (a -> b) -> a -> b
$ do
    Int -> IO ()
threadDelay Int
100_000
    FilePath -> IO ()
waitForFile FilePath
fp

-- | 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{FilePath
rnNodeSocket :: FilePath
rnNodeSocket :: RunningNode -> FilePath
rnNodeSocket, NetworkId
rnNetworkId :: NetworkId
rnNetworkId :: RunningNode -> NetworkId
rnNetworkId} = do
  SystemStart
systemStart <- NetworkId -> FilePath -> IO SystemStart
Q.querySystemStart NetworkId
rnNetworkId FilePath
rnNodeSocket
  SystemStart -> IO ()
check SystemStart
systemStart
 where
  check :: SystemStart -> IO ()
check SystemStart
systemStart = do
    RelativeTime
targetTime <- SystemStart -> UTCTime -> RelativeTime
toRelativeTime SystemStart
systemStart forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
    EraHistory CardanoMode
eraHistory <- NetworkId -> FilePath -> IO (EraHistory CardanoMode)
Q.queryEraHistory NetworkId
rnNetworkId FilePath
rnNodeSocket
    (SlotNo
tipSlotNo, SlotLength
_slotLength) <- NetworkId -> FilePath -> IO (SlotNo, SlotLength)
Q.queryTipSlotNo NetworkId
rnNetworkId FilePath
rnNodeSocket
    (RelativeTime
tipTime, SlotLength
_slotLength) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall mode.
SlotNo
-> EraHistory mode
-> Either PastHorizonException (RelativeTime, SlotLength)
C.getProgress SlotNo
tipSlotNo EraHistory CardanoMode
eraHistory
    let timeDifference :: NominalDiffTime
timeDifference = RelativeTime -> RelativeTime -> NominalDiffTime
diffRelativeTime RelativeTime
targetTime RelativeTime
tipTime
    let percentDone :: Centi
percentDone = forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime
100.0 forall a. Num a => a -> a -> a
* RelativeTime -> NominalDiffTime
getRelativeTime RelativeTime
tipTime forall a. Fractional a => a -> a -> a
/ RelativeTime -> NominalDiffTime
getRelativeTime RelativeTime
targetTime)
    forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tracer forall a b. (a -> b) -> a -> b
$ MsgSynchronizing{Centi
percentDone :: Centi
percentDone :: Centi
percentDone}
    if NominalDiffTime
timeDifference forall a. Ord a => a -> a -> Bool
< NominalDiffTime
20 -- TODO: derive from known network and block times
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      else Int -> IO ()
threadDelay Int
3_000_000 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SystemStart -> IO ()
check SystemStart
systemStart

{-| Wait until at least one block has been produced (ie. the tip is not genesis)
-}
waitForBlock :: RunningNode -> IO C.BlockNo
waitForBlock :: RunningNode -> IO BlockNo
waitForBlock n :: RunningNode
n@RunningNode{FilePath
rnNodeSocket :: FilePath
rnNodeSocket :: RunningNode -> FilePath
rnNodeSocket, NetworkId
rnNetworkId :: NetworkId
rnNetworkId :: RunningNode -> NetworkId
rnNetworkId} = do
  forall t. WithOrigin t -> Maybe t
withOriginToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId -> FilePath -> IO (WithOrigin BlockNo)
Q.queryTipBlock NetworkId
rnNetworkId FilePath
rnNodeSocket forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just BlockNo
blockNo | BlockNo
blockNo forall a. Ord a => a -> a -> Bool
>= BlockNo
1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockNo
blockNo
    Maybe BlockNo
_ -> do
      Int -> IO ()
threadDelay Int
1_000_000 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RunningNode -> IO BlockNo
waitForBlock RunningNode
n

{-| Modifications to apply to the default genesis configurations
-}
data GenesisConfigChanges =
  GenesisConfigChanges
    { GenesisConfigChanges
-> ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
cfShelley :: ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
    , GenesisConfigChanges -> AlonzoGenesis -> AlonzoGenesis
cfAlonzo  :: AlonzoGenesis -> AlonzoGenesis
    , GenesisConfigChanges
-> ConwayGenesis StandardCrypto -> ConwayGenesis StandardCrypto
cfConway  :: ConwayGenesis StandardCrypto -> ConwayGenesis StandardCrypto
    }

instance Semigroup GenesisConfigChanges where
  GenesisConfigChanges
l <> :: GenesisConfigChanges
-> GenesisConfigChanges -> GenesisConfigChanges
<> GenesisConfigChanges
r =
    GenesisConfigChanges
      { cfShelley :: ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
cfShelley = GenesisConfigChanges
-> ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
cfShelley GenesisConfigChanges
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisConfigChanges
-> ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
cfShelley GenesisConfigChanges
l
      , cfAlonzo :: AlonzoGenesis -> AlonzoGenesis
cfAlonzo  = GenesisConfigChanges -> AlonzoGenesis -> AlonzoGenesis
cfAlonzo  GenesisConfigChanges
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisConfigChanges -> AlonzoGenesis -> AlonzoGenesis
cfAlonzo GenesisConfigChanges
l
      , cfConway :: ConwayGenesis StandardCrypto -> ConwayGenesis StandardCrypto
cfConway  = GenesisConfigChanges
-> ConwayGenesis StandardCrypto -> ConwayGenesis StandardCrypto
cfConway  GenesisConfigChanges
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisConfigChanges
-> ConwayGenesis StandardCrypto -> ConwayGenesis StandardCrypto
cfConway GenesisConfigChanges
l
      }

instance Monoid GenesisConfigChanges where
  mempty :: GenesisConfigChanges
mempty = (ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto)
-> (AlonzoGenesis -> AlonzoGenesis)
-> (ConwayGenesis StandardCrypto -> ConwayGenesis StandardCrypto)
-> GenesisConfigChanges
GenesisConfigChanges forall a. a -> a
id forall a. a -> a
id forall a. a -> a
id

-- {-| Change the alonzo genesis config to allow transactions with up to twice the normal size
-- -}
allowLargeTransactions :: GenesisConfigChanges
allowLargeTransactions :: GenesisConfigChanges
allowLargeTransactions =
  let change :: ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
      change :: ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
change ShelleyGenesis StandardCrypto
g = ShelleyGenesis StandardCrypto
g{sgProtocolParams :: PParams (ShelleyEra StandardCrypto)
sgProtocolParams = PParams (ShelleyEra StandardCrypto)
-> PParams (ShelleyEra StandardCrypto)
double (forall c. ShelleyGenesis c -> PParams (ShelleyEra c)
sgProtocolParams ShelleyGenesis StandardCrypto
g)}
      double :: Core.PParams (ShelleyEra StandardCrypto) -> Core.PParams (ShelleyEra StandardCrypto)
      double :: PParams (ShelleyEra StandardCrypto)
-> PParams (ShelleyEra StandardCrypto)
double = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall era. Lens' (PParams era) (PParamsHKD Identity era)
Core.ppLens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era (f :: * -> *).
(EraPParams era, HKDFunctor f) =>
Lens' (PParamsHKD f era) (HKD f Natural)
Core.hkdMaxTxSizeL) (forall a. Num a => a -> a -> a
*HKD Identity Natural
2)
  in forall a. Monoid a => a
mempty{cfShelley :: ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
cfShelley = ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
change}

-- | 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 =
  forall a.
Tracer IO NodeLog
-> FilePath
-> GenesisConfigChanges
-> (RunningNode -> IO a)
-> IO a
withCardanoNodeDevnetConfig Tracer IO NodeLog
tracer FilePath
stateDirectory forall a. Monoid a => a
mempty RunningNode -> IO 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.
withCardanoNodeDevnetConfig ::
  Tracer IO NodeLog ->
  -- | State directory in which credentials, db & logs are persisted.
  FilePath ->
  -- | Changes to apply to the default genesis configurations
  GenesisConfigChanges ->
  (RunningNode -> IO a) ->
  IO a
withCardanoNodeDevnetConfig :: forall a.
Tracer IO NodeLog
-> FilePath
-> GenesisConfigChanges
-> (RunningNode -> IO a)
-> IO a
withCardanoNodeDevnetConfig Tracer IO NodeLog
tracer FilePath
stateDirectory GenesisConfigChanges
configChanges RunningNode -> IO a
action = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
stateDirectory
  [FilePath
dlgCert, FilePath
signKey, FilePath
vrfKey, FilePath
kesKey, FilePath
opCert] <-
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 :: Maybe FilePath
nodeDlgCertFile = forall a. a -> Maybe a
Just FilePath
dlgCert
          , nodeSignKeyFile :: Maybe FilePath
nodeSignKeyFile = forall a. a -> Maybe a
Just FilePath
signKey
          , nodeVrfKeyFile :: Maybe FilePath
nodeVrfKeyFile = forall a. a -> Maybe a
Just FilePath
vrfKey
          , nodeKesKeyFile :: Maybe FilePath
nodeKesKeyFile = forall a. a -> Maybe a
Just FilePath
kesKey
          , nodeOpCertFile :: Maybe FilePath
nodeOpCertFile = forall a. a -> Maybe a
Just FilePath
opCert
          }
  CardanoNodeArgs -> IO ()
copyDevnetFiles CardanoNodeArgs
args
  FilePath -> CardanoNodeArgs -> IO ()
refreshSystemStart FilePath
stateDirectory CardanoNodeArgs
args
  [Int] -> CardanoNodeArgs -> IO ()
writeTopology [] CardanoNodeArgs
args

  forall a.
Tracer IO NodeLog
-> NetworkId
-> FilePath
-> CardanoNodeArgs
-> (RunningNode -> IO a)
-> IO a
withCardanoNode Tracer IO NodeLog
tracer NetworkId
networkId FilePath
stateDirectory CardanoNodeArgs
args forall a b. (a -> b) -> a -> b
$ \RunningNode
rn -> do
    forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tracer NodeLog
MsgNodeIsReady
    RunningNode -> IO a
action RunningNode
rn
 where
  -- NOTE: This needs to match what's in config/genesis-shelley.json
  networkId :: NetworkId
networkId = NetworkId
defaultNetworkId

  copyDevnetCredential :: FilePath -> IO FilePath
copyDevnetCredential FilePath
file = do
    let destination :: FilePath
destination = FilePath
stateDirectory FilePath -> ShowS
</> FilePath
file
    Bool
x <- FilePath -> IO Bool
doesFileExist FilePath
destination
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
x forall a b. (a -> b) -> a -> b
$
      FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
file)
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
BS.writeFile FilePath
destination
    FilePath -> FileMode -> IO ()
setFileMode FilePath
destination FileMode
ownerReadMode
    forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
destination

  GenesisConfigChanges{AlonzoGenesis -> AlonzoGenesis
cfAlonzo :: AlonzoGenesis -> AlonzoGenesis
cfAlonzo :: GenesisConfigChanges -> AlonzoGenesis -> AlonzoGenesis
cfAlonzo, ConwayGenesis StandardCrypto -> ConwayGenesis StandardCrypto
cfConway :: ConwayGenesis StandardCrypto -> ConwayGenesis StandardCrypto
cfConway :: GenesisConfigChanges
-> ConwayGenesis StandardCrypto -> ConwayGenesis StandardCrypto
cfConway, ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
cfShelley :: ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
cfShelley :: GenesisConfigChanges
-> ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
cfShelley} = GenesisConfigChanges
configChanges

  copyDevnetFiles :: CardanoNodeArgs -> IO ()
copyDevnetFiles CardanoNodeArgs
args = do
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"cardano-node.json")
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
BS.writeFile
        (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConfigFile CardanoNodeArgs
args)
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-byron.json")
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
BS.writeFile
        (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeByronGenesisFile CardanoNodeArgs
args)
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-shelley.json")
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
(FromJSON a, ToJSON a) =>
(a -> a) -> FilePath -> ByteString -> IO ()
copyAndChangeJSONFile
        ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto
cfShelley
        (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args)
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-alonzo.json")
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
(FromJSON a, ToJSON a) =>
(a -> a) -> FilePath -> ByteString -> IO ()
copyAndChangeJSONFile
        AlonzoGenesis -> AlonzoGenesis
cfAlonzo
        (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeAlonzoGenesisFile CardanoNodeArgs
args)
    FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-conway.json")
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
(FromJSON a, ToJSON a) =>
(a -> a) -> FilePath -> ByteString -> IO ()
copyAndChangeJSONFile
        ConwayGenesis StandardCrypto -> ConwayGenesis StandardCrypto
cfConway
        (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConwayGenesisFile CardanoNodeArgs
args)

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

{-| Decode a json file, change the value, and write the result to another JSON file
-}
copyAndChangeJSONFile :: (FromJSON a, ToJSON a) => (a -> a) -> FilePath -> BS.ByteString -> IO ()
copyAndChangeJSONFile :: forall a.
(FromJSON a, ToJSON a) =>
(a -> a) -> FilePath -> ByteString -> IO ()
copyAndChangeJSONFile a -> a
modification FilePath
target =
  FilePath -> ByteString -> IO ()
BS.writeFile
        FilePath
target
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.toStrict
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Aeson.encode
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => FilePath -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Semigroup a => a -> a -> a
(<>) FilePath
"Failed to decode json: ") a -> a
modification
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecode
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.fromStrict

-- | 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 forall a b. (a -> b) -> a -> b
$ UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
systemStart
  Value
byronGenesis <-
    forall a. FromJSON a => FilePath -> IO a
unsafeDecodeJsonFile (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeByronGenesisFile CardanoNodeArgs
args)
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. ToJSON a => Key -> a -> Value -> Value
addField Key
"startTime" Int
startTime

  let systemStartUTC :: UTCTime
systemStartUTC =
        NominalDiffTime -> UTCTime
posixSecondsToUTCTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational forall a b. (a -> b) -> a -> b
$ Int
startTime
  Value
shelleyGenesis <-
    forall a. FromJSON a => FilePath -> IO a
unsafeDecodeJsonFile (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args)
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. ToJSON a => Key -> a -> Value -> Value
addField Key
"systemStart" UTCTime
systemStartUTC

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

  FilePath
byronGenesisHash <- FilePath -> IO FilePath
computeGenesisHash (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeByronGenesisFile CardanoNodeArgs
args)
  FilePath
shelleyGenesisHash <- FilePath -> IO FilePath
computeGenesisHash (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args)
  FilePath
alonzoGenesisHash <- FilePath -> IO FilePath
computeGenesisHash (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeAlonzoGenesisFile CardanoNodeArgs
args)
  FilePath
conwayGenesisHash <- FilePath -> IO FilePath
computeGenesisHash (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConwayGenesisFile CardanoNodeArgs
args)

  Value
config <-
    forall a. FromJSON a => FilePath -> IO a
unsafeDecodeJsonFile (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConfigFile CardanoNodeArgs
args)
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. ToJSON a => Key -> a -> Value -> Value
addField Key
"ByronGenesisFile" (CardanoNodeArgs -> FilePath
nodeByronGenesisFile CardanoNodeArgs
args)
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. ToJSON a => Key -> a -> Value -> Value
addField Key
"ByronGenesisHash" FilePath
byronGenesisHash
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. ToJSON a => Key -> a -> Value -> Value
addField Key
"ShelleyGenesisFile" (CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args)
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. ToJSON a => Key -> a -> Value -> Value
addField Key
"ShelleyGenesisHash" FilePath
shelleyGenesisHash
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. ToJSON a => Key -> a -> Value -> Value
addField Key
"AlonzoGenesisHash" FilePath
alonzoGenesisHash
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. ToJSON a => Key -> a -> Value -> Value
addField Key
"ConwayGenesisHash" FilePath
conwayGenesisHash

  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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"127.0.0.1" :: Text), Key
"port" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
port, Key
"valency" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Int
1 :: Int)]

-- | 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime

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

addField :: ToJSON a => Aeson.Key -> a -> Aeson.Value -> Aeson.Value
addField :: forall a. ToJSON a => Key -> a -> Value -> Value
addField Key
k a
v = (Object -> Object) -> Value -> Value
withObject (forall v. Key -> v -> KeyMap v -> KeyMap v
Aeson.KeyMap.insert Key
k (forall a. ToJSON a => a -> Value
toJSON a
v))

-- | 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

{-| Compute the hash of a genesis file using cardano-cli
-}
computeGenesisHash :: FilePath -> IO String
computeGenesisHash :: FilePath -> IO FilePath
computeGenesisHash FilePath
fp =
  -- drop the last character (newline)
  forall a. Int -> [a] -> [a]
take Int
64 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"cardano-cli" [FilePath
"genesis", FilePath
"hash", FilePath
"--genesis", FilePath
fp] FilePath
""