{-# LANGUAGE DuplicateRecordFields #-}
module CardanoNode where
import Hydra.Prelude
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.Fixed (Centi)
import Data.Text qualified as Text
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Hydra.Cardano.Api (
File (..),
NetworkId,
NetworkMagic (..),
SocketPath,
getProgress,
)
import Hydra.Cardano.Api qualified as Api
import Hydra.Chain.Backend (ChainBackend)
import Hydra.Chain.Backend qualified as Backend
import Hydra.Chain.Direct (DirectBackend (..))
import Hydra.Cluster.Fixture (KnownNetwork (..), toNetworkId)
import Hydra.Cluster.Util (readConfigFile)
import Hydra.Options (DirectOptions (..))
import Network.HTTP.Simple (getResponseBody, httpBS, parseRequestThrow)
import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)
import System.Exit (ExitCode (..))
import System.FilePath (takeDirectory, (</>))
import System.Posix (ownerReadMode, setFileMode)
import System.Process (
CreateProcess (..),
StdStream (CreatePipe, UseHandle),
proc,
readProcess,
withCreateProcess,
)
import Test.Hydra.Prelude
data NodeLog
= MsgNodeCmdSpec {NodeLog -> Text
cmd :: Text}
| MsgCLI [Text]
| MsgCLIStatus Text Text
| MsgCLIRetry Text
| MsgCLIRetryResult Text Int
| MsgNodeStarting {NodeLog -> FilePath
stateDirectory :: FilePath}
| MsgSocketIsReady SocketPath
| MsgSynchronizing {NodeLog -> Centi
percentDone :: Centi}
| MsgQueryGenesisParametersFailed {NodeLog -> Text
err :: Text}
deriving stock (NodeLog -> NodeLog -> Bool
(NodeLog -> NodeLog -> Bool)
-> (NodeLog -> NodeLog -> Bool) -> Eq NodeLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeLog -> NodeLog -> Bool
== :: NodeLog -> NodeLog -> Bool
$c/= :: NodeLog -> NodeLog -> Bool
/= :: NodeLog -> NodeLog -> Bool
Eq, Int -> NodeLog -> ShowS
[NodeLog] -> ShowS
NodeLog -> FilePath
(Int -> NodeLog -> ShowS)
-> (NodeLog -> FilePath) -> ([NodeLog] -> ShowS) -> Show NodeLog
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeLog -> ShowS
showsPrec :: Int -> NodeLog -> ShowS
$cshow :: NodeLog -> FilePath
show :: NodeLog -> FilePath
$cshowList :: [NodeLog] -> ShowS
showList :: [NodeLog] -> ShowS
Show, (forall x. NodeLog -> Rep NodeLog x)
-> (forall x. Rep NodeLog x -> NodeLog) -> Generic NodeLog
forall x. Rep NodeLog x -> NodeLog
forall x. NodeLog -> Rep NodeLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NodeLog -> Rep NodeLog x
from :: forall x. NodeLog -> Rep NodeLog x
$cto :: forall x. Rep NodeLog x -> NodeLog
to :: forall x. Rep NodeLog x -> NodeLog
Generic)
deriving anyclass ([NodeLog] -> Value
[NodeLog] -> Encoding
NodeLog -> Bool
NodeLog -> Value
NodeLog -> Encoding
(NodeLog -> Value)
-> (NodeLog -> Encoding)
-> ([NodeLog] -> Value)
-> ([NodeLog] -> Encoding)
-> (NodeLog -> Bool)
-> ToJSON NodeLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: NodeLog -> Value
toJSON :: NodeLog -> Value
$ctoEncoding :: NodeLog -> Encoding
toEncoding :: NodeLog -> Encoding
$ctoJSONList :: [NodeLog] -> Value
toJSONList :: [NodeLog] -> Value
$ctoEncodingList :: [NodeLog] -> Encoding
toEncodingList :: [NodeLog] -> Encoding
$comitField :: NodeLog -> Bool
omitField :: NodeLog -> Bool
ToJSON)
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)
data DevnetConfig = DevnetConfig
{ DevnetConfig -> FilePath
stateDirectory :: FilePath
, DevnetConfig -> UTCTime
systemStart :: UTCTime
, DevnetConfig -> PortsConfig
ports :: PortsConfig
}
deriving stock (DevnetConfig -> DevnetConfig -> Bool
(DevnetConfig -> DevnetConfig -> Bool)
-> (DevnetConfig -> DevnetConfig -> Bool) -> Eq DevnetConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DevnetConfig -> DevnetConfig -> Bool
== :: DevnetConfig -> DevnetConfig -> Bool
$c/= :: DevnetConfig -> DevnetConfig -> Bool
/= :: DevnetConfig -> DevnetConfig -> Bool
Eq, Int -> DevnetConfig -> ShowS
[DevnetConfig] -> ShowS
DevnetConfig -> FilePath
(Int -> DevnetConfig -> ShowS)
-> (DevnetConfig -> FilePath)
-> ([DevnetConfig] -> ShowS)
-> Show DevnetConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DevnetConfig -> ShowS
showsPrec :: Int -> DevnetConfig -> ShowS
$cshow :: DevnetConfig -> FilePath
show :: DevnetConfig -> FilePath
$cshowList :: [DevnetConfig] -> ShowS
showList :: [DevnetConfig] -> ShowS
Show, (forall x. DevnetConfig -> Rep DevnetConfig x)
-> (forall x. Rep DevnetConfig x -> DevnetConfig)
-> Generic DevnetConfig
forall x. Rep DevnetConfig x -> DevnetConfig
forall x. DevnetConfig -> Rep DevnetConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DevnetConfig -> Rep DevnetConfig x
from :: forall x. DevnetConfig -> Rep DevnetConfig x
$cto :: forall x. Rep DevnetConfig x -> DevnetConfig
to :: forall x. Rep DevnetConfig x -> DevnetConfig
Generic)
data CardanoNodeArgs = CardanoNodeArgs
{ CardanoNodeArgs -> FilePath
nodeSocket :: FilePath
, CardanoNodeArgs -> FilePath
nodeConfigFile :: FilePath
, CardanoNodeArgs -> FilePath
nodeByronGenesisFile :: FilePath
, CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile :: FilePath
, CardanoNodeArgs -> FilePath
nodeAlonzoGenesisFile :: FilePath
, CardanoNodeArgs -> FilePath
nodeConwayGenesisFile :: FilePath
, CardanoNodeArgs -> FilePath
nodeTopologyFile :: FilePath
, CardanoNodeArgs -> FilePath
nodeDatabaseDir :: FilePath
, CardanoNodeArgs -> Maybe FilePath
nodeDlgCertFile :: Maybe FilePath
, CardanoNodeArgs -> Maybe FilePath
nodeSignKeyFile :: Maybe FilePath
, CardanoNodeArgs -> Maybe FilePath
nodeOpCertFile :: Maybe FilePath
, CardanoNodeArgs -> Maybe FilePath
nodeKesKeyFile :: Maybe FilePath
, CardanoNodeArgs -> Maybe FilePath
nodeVrfKeyFile :: Maybe FilePath
, CardanoNodeArgs -> Maybe Int
nodePort :: Maybe Port
}
defaultCardanoNodeArgs :: CardanoNodeArgs
defaultCardanoNodeArgs :: CardanoNodeArgs
defaultCardanoNodeArgs =
CardanoNodeArgs
{ $sel:nodeSocket:CardanoNodeArgs :: FilePath
nodeSocket = FilePath
"node.socket"
, $sel:nodeConfigFile:CardanoNodeArgs :: FilePath
nodeConfigFile = FilePath
"cardano-node.json"
, $sel:nodeByronGenesisFile:CardanoNodeArgs :: FilePath
nodeByronGenesisFile = FilePath
"genesis-byron.json"
, $sel:nodeShelleyGenesisFile:CardanoNodeArgs :: FilePath
nodeShelleyGenesisFile = FilePath
"genesis-shelley.json"
, $sel:nodeAlonzoGenesisFile:CardanoNodeArgs :: FilePath
nodeAlonzoGenesisFile = FilePath
"genesis-alonzo.json"
, $sel:nodeConwayGenesisFile:CardanoNodeArgs :: FilePath
nodeConwayGenesisFile = FilePath
"genesis-conway.json"
, $sel:nodeTopologyFile:CardanoNodeArgs :: FilePath
nodeTopologyFile = FilePath
"topology.json"
, $sel:nodeDatabaseDir:CardanoNodeArgs :: FilePath
nodeDatabaseDir = FilePath
"db"
, $sel:nodeDlgCertFile:CardanoNodeArgs :: Maybe FilePath
nodeDlgCertFile = Maybe FilePath
forall a. Maybe a
Nothing
, $sel:nodeSignKeyFile:CardanoNodeArgs :: Maybe FilePath
nodeSignKeyFile = Maybe FilePath
forall a. Maybe a
Nothing
, $sel:nodeOpCertFile:CardanoNodeArgs :: Maybe FilePath
nodeOpCertFile = Maybe FilePath
forall a. Maybe a
Nothing
, $sel:nodeKesKeyFile:CardanoNodeArgs :: Maybe FilePath
nodeKesKeyFile = Maybe FilePath
forall a. Maybe a
Nothing
, $sel:nodeVrfKeyFile:CardanoNodeArgs :: Maybe FilePath
nodeVrfKeyFile = Maybe FilePath
forall a. Maybe a
Nothing
, $sel:nodePort:CardanoNodeArgs :: Maybe Int
nodePort = Maybe Int
forall a. Maybe a
Nothing
}
data PortsConfig = PortsConfig
{ PortsConfig -> Int
ours :: Port
, PortsConfig -> [Int]
peers :: [Port]
}
deriving stock (Int -> PortsConfig -> ShowS
[PortsConfig] -> ShowS
PortsConfig -> FilePath
(Int -> PortsConfig -> ShowS)
-> (PortsConfig -> FilePath)
-> ([PortsConfig] -> ShowS)
-> Show PortsConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PortsConfig -> ShowS
showsPrec :: Int -> PortsConfig -> ShowS
$cshow :: PortsConfig -> FilePath
show :: PortsConfig -> FilePath
$cshowList :: [PortsConfig] -> ShowS
showList :: [PortsConfig] -> ShowS
Show, PortsConfig -> PortsConfig -> Bool
(PortsConfig -> PortsConfig -> Bool)
-> (PortsConfig -> PortsConfig -> Bool) -> Eq PortsConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PortsConfig -> PortsConfig -> Bool
== :: PortsConfig -> PortsConfig -> Bool
$c/= :: PortsConfig -> PortsConfig -> Bool
/= :: PortsConfig -> PortsConfig -> Bool
Eq, (forall x. PortsConfig -> Rep PortsConfig x)
-> (forall x. Rep PortsConfig x -> PortsConfig)
-> Generic PortsConfig
forall x. Rep PortsConfig x -> PortsConfig
forall x. PortsConfig -> Rep PortsConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PortsConfig -> Rep PortsConfig x
from :: forall x. PortsConfig -> Rep PortsConfig x
$cto :: forall x. Rep PortsConfig x -> PortsConfig
to :: forall x. Rep PortsConfig x -> PortsConfig
Generic)
getCardanoNodeVersion :: IO String
getCardanoNodeVersion :: IO FilePath
getCardanoNodeVersion =
FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"cardano-node" [FilePath
"--version"] FilePath
""
findRunningCardanoNode :: Tracer IO NodeLog -> FilePath -> KnownNetwork -> IO (Maybe (NominalDiffTime, DirectBackend))
findRunningCardanoNode :: Tracer IO NodeLog
-> FilePath
-> KnownNetwork
-> IO (Maybe (NominalDiffTime, DirectBackend))
findRunningCardanoNode Tracer IO NodeLog
tracer FilePath
workDir KnownNetwork
knownNetwork = do
Tracer IO NodeLog
-> NetworkId
-> SocketPath
-> IO (Maybe (NominalDiffTime, DirectBackend))
findRunningCardanoNode' Tracer IO NodeLog
tracer NetworkId
knownNetworkId SocketPath
socketPath
where
knownNetworkId :: NetworkId
knownNetworkId = KnownNetwork -> NetworkId
toNetworkId KnownNetwork
knownNetwork
socketPath :: SocketPath
socketPath = FilePath -> SocketPath
forall content (direction :: FileDirection).
FilePath -> File content direction
File (FilePath -> SocketPath) -> FilePath -> SocketPath
forall a b. (a -> b) -> a -> b
$ FilePath
workDir FilePath -> ShowS
</> FilePath
nodeSocket
CardanoNodeArgs{FilePath
$sel:nodeSocket:CardanoNodeArgs :: CardanoNodeArgs -> FilePath
nodeSocket :: FilePath
nodeSocket} = CardanoNodeArgs
defaultCardanoNodeArgs
findRunningCardanoNode' :: Tracer IO NodeLog -> NetworkId -> SocketPath -> IO (Maybe (NominalDiffTime, DirectBackend))
findRunningCardanoNode' :: Tracer IO NodeLog
-> NetworkId
-> SocketPath
-> IO (Maybe (NominalDiffTime, DirectBackend))
findRunningCardanoNode' Tracer IO NodeLog
tracer NetworkId
networkId SocketPath
nodeSocket = do
let backend :: DirectBackend
backend = DirectOptions -> DirectBackend
DirectBackend (DirectOptions -> DirectBackend) -> DirectOptions -> DirectBackend
forall a b. (a -> b) -> a -> b
$ 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 (DirectBackend -> (MonadIO IO, MonadThrow IO) => IO NominalDiffTime
forall a (m :: * -> *).
ChainBackend a =>
a -> (MonadIO m, MonadThrow m) => m NominalDiffTime
forall (m :: * -> *).
DirectBackend -> (MonadIO m, MonadThrow m) => m NominalDiffTime
Backend.getBlockTime DirectBackend
backend) IO (Either SomeException NominalDiffTime)
-> (Either SomeException NominalDiffTime
-> IO (Maybe (NominalDiffTime, DirectBackend)))
-> IO (Maybe (NominalDiffTime, DirectBackend))
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, DirectBackend)
-> IO (Maybe (NominalDiffTime, DirectBackend))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe (NominalDiffTime, DirectBackend)
forall a. Maybe a
Nothing
Right NominalDiffTime
blockTime ->
Maybe (NominalDiffTime, DirectBackend)
-> IO (Maybe (NominalDiffTime, DirectBackend))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (NominalDiffTime, DirectBackend)
-> IO (Maybe (NominalDiffTime, DirectBackend)))
-> Maybe (NominalDiffTime, DirectBackend)
-> IO (Maybe (NominalDiffTime, DirectBackend))
forall a b. (a -> b) -> a -> b
$ (NominalDiffTime, DirectBackend)
-> Maybe (NominalDiffTime, DirectBackend)
forall a. a -> Maybe a
Just (NominalDiffTime
blockTime, DirectBackend
backend)
withCardanoNodeDevnet ::
Tracer IO NodeLog ->
FilePath ->
(NominalDiffTime -> DirectBackend -> IO a) ->
IO a
withCardanoNodeDevnet :: forall a.
Tracer IO NodeLog
-> FilePath -> (NominalDiffTime -> DirectBackend -> IO a) -> IO a
withCardanoNodeDevnet Tracer IO NodeLog
tracer FilePath
stateDirectory NominalDiffTime -> DirectBackend -> IO a
action = do
CardanoNodeArgs
args <- FilePath -> IO CardanoNodeArgs
setupCardanoDevnet FilePath
stateDirectory
Tracer IO NodeLog
-> FilePath
-> CardanoNodeArgs
-> (NominalDiffTime -> DirectBackend -> IO a)
-> IO a
forall a.
Tracer IO NodeLog
-> FilePath
-> CardanoNodeArgs
-> (NominalDiffTime -> DirectBackend -> IO a)
-> IO a
withCardanoNode Tracer IO NodeLog
tracer FilePath
stateDirectory CardanoNodeArgs
args NominalDiffTime -> DirectBackend -> IO a
action
withCardanoNodeOnKnownNetwork ::
Tracer IO NodeLog ->
FilePath ->
KnownNetwork ->
(NominalDiffTime -> DirectBackend -> IO a) ->
IO a
withCardanoNodeOnKnownNetwork :: forall a.
Tracer IO NodeLog
-> FilePath
-> KnownNetwork
-> (NominalDiffTime -> DirectBackend -> IO a)
-> IO a
withCardanoNodeOnKnownNetwork Tracer IO NodeLog
tracer FilePath
stateDirectory KnownNetwork
knownNetwork NominalDiffTime -> DirectBackend -> IO a
action = do
IO ()
copyKnownNetworkFiles
Tracer IO NodeLog
-> FilePath
-> CardanoNodeArgs
-> (NominalDiffTime -> DirectBackend -> IO a)
-> IO a
forall a.
Tracer IO NodeLog
-> FilePath
-> CardanoNodeArgs
-> (NominalDiffTime -> DirectBackend -> IO a)
-> IO a
withCardanoNode Tracer IO NodeLog
tracer FilePath
stateDirectory CardanoNodeArgs
args NominalDiffTime -> DirectBackend -> 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"
}
copyKnownNetworkFiles :: IO ()
copyKnownNetworkFiles =
[FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
[ FilePath
"config.json"
, FilePath
"topology.json"
, FilePath
"byron-genesis.json"
, FilePath
"shelley-genesis.json"
, FilePath
"alonzo-genesis.json"
, FilePath
"conway-genesis.json"
]
((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
fn -> do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
stateDirectory FilePath -> ShowS
</> ShowS
takeDirectory FilePath
fn
FilePath -> IO ByteString
forall {f :: * -> *}.
(MonadThrow f, MonadIO f) =>
FilePath -> f ByteString
fetchConfigFile (FilePath
knownNetworkPath FilePath -> ShowS
</> FilePath
fn)
IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS (FilePath
stateDirectory FilePath -> ShowS
</> FilePath
fn)
knownNetworkPath :: FilePath
knownNetworkPath =
FilePath
knownNetworkConfigBaseURL FilePath -> ShowS
</> FilePath
knownNetworkName
knownNetworkConfigBaseURL :: FilePath
knownNetworkConfigBaseURL = FilePath
"https://book.world.dev.cardano.org/environments"
knownNetworkName :: FilePath
knownNetworkName = case KnownNetwork
knownNetwork of
KnownNetwork
Preview -> FilePath
"preview"
KnownNetwork
Preproduction -> FilePath
"preprod"
KnownNetwork
Mainnet -> FilePath
"mainnet"
KnownNetwork
Sanchonet -> FilePath
"sanchonet"
KnownNetwork
BlockfrostPreview -> FilePath
"preview"
KnownNetwork
BlockfrostPreprod -> FilePath
"preprod"
KnownNetwork
BlockfrostMainnet -> FilePath
"mainnet"
fetchConfigFile :: FilePath -> f ByteString
fetchConfigFile FilePath
path =
FilePath -> f Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequestThrow FilePath
path f Request
-> (Request -> f (Response ByteString)) -> f (Response ByteString)
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> f (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpBS f (Response ByteString)
-> (Response ByteString -> ByteString) -> f ByteString
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody
setupCardanoDevnet :: FilePath -> IO CardanoNodeArgs
setupCardanoDevnet :: FilePath -> IO CardanoNodeArgs
setupCardanoDevnet FilePath
stateDirectory = do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
stateDirectory
[FilePath
dlgCert, FilePath
signKey, FilePath
vrfKey, FilePath
kesKey, FilePath
opCert] <-
(FilePath -> IO FilePath) -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
FilePath -> IO FilePath
copyDevnetCredential
[ FilePath
"byron-delegation.cert"
, FilePath
"byron-delegate.key"
, FilePath
"vrf.skey"
, FilePath
"kes.skey"
, FilePath
"opcert.cert"
]
let args :: CardanoNodeArgs
args =
CardanoNodeArgs
defaultCardanoNodeArgs
{ nodeDlgCertFile = Just dlgCert
, nodeSignKeyFile = Just signKey
, nodeVrfKeyFile = Just vrfKey
, nodeKesKeyFile = Just kesKey
, nodeOpCertFile = Just opCert
}
CardanoNodeArgs -> IO ()
copyDevnetFiles CardanoNodeArgs
args
FilePath -> CardanoNodeArgs -> IO ()
refreshSystemStart FilePath
stateDirectory CardanoNodeArgs
args
[Int] -> CardanoNodeArgs -> IO ()
writeTopology [] CardanoNodeArgs
args
CardanoNodeArgs -> IO CardanoNodeArgs
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CardanoNodeArgs
args
where
copyDevnetCredential :: FilePath -> IO FilePath
copyDevnetCredential FilePath
file = do
let destination :: FilePath
destination = FilePath
stateDirectory FilePath -> ShowS
</> FilePath
file
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> IO Bool
doesFileExist FilePath
destination) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
file)
IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS FilePath
destination
FilePath -> FileMode -> IO ()
setFileMode FilePath
destination FileMode
ownerReadMode
FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
file
copyDevnetFiles :: CardanoNodeArgs -> IO ()
copyDevnetFiles CardanoNodeArgs
args = do
FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"cardano-node.json")
IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS
(FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConfigFile CardanoNodeArgs
args)
FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-byron.json")
IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS
(FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeByronGenesisFile CardanoNodeArgs
args)
FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-shelley.json")
IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS
(FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeShelleyGenesisFile CardanoNodeArgs
args)
FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-alonzo.json")
IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS
(FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeAlonzoGenesisFile CardanoNodeArgs
args)
FilePath -> IO ByteString
readConfigFile (FilePath
"devnet" FilePath -> ShowS
</> FilePath
"genesis-conway.json")
IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS
(FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeConwayGenesisFile CardanoNodeArgs
args)
writeTopology :: [Int] -> CardanoNodeArgs -> IO ()
writeTopology [Int]
peers CardanoNodeArgs
args =
FilePath -> Value -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile (FilePath
stateDirectory FilePath -> ShowS
</> CardanoNodeArgs -> FilePath
nodeTopologyFile CardanoNodeArgs
args) (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
[Int] -> Value
mkTopology [Int]
peers
withCardanoNode ::
Tracer IO NodeLog ->
FilePath ->
CardanoNodeArgs ->
(NominalDiffTime -> DirectBackend -> IO a) ->
IO a
withCardanoNode :: forall a.
Tracer IO NodeLog
-> FilePath
-> CardanoNodeArgs
-> (NominalDiffTime -> DirectBackend -> IO a)
-> IO a
withCardanoNode Tracer IO NodeLog
tr FilePath
stateDirectory CardanoNodeArgs
args NominalDiffTime -> DirectBackend -> IO a
action = do
Tracer IO NodeLog -> NodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tr (NodeLog -> IO ()) -> NodeLog -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> NodeLog
MsgNodeCmdSpec (CmdSpec -> Text
forall b a. (Show a, IsString b) => a -> b
show (CmdSpec -> Text) -> CmdSpec -> Text
forall a b. (a -> b) -> a -> b
$ CreateProcess -> CmdSpec
cmdspec CreateProcess
process)
FilePath -> (Handle -> IO a) -> IO a
forall a. FilePath -> (Handle -> IO a) -> IO a
withLogFile FilePath
logFilePath ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
out -> do
Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
out BufferMode
NoBuffering
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
process{std_out = UseHandle out, std_err = CreatePipe} ((Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a)
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$
\Maybe Handle
_stdin Maybe Handle
_stdout Maybe Handle
mError ProcessHandle
processHandle ->
(IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` IO ()
cleanupSocketFile) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
IO Void -> IO a -> IO (Either Void a)
forall a b. IO a -> IO b -> IO (Either a b)
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> m b -> m (Either a b)
race (Text -> ProcessHandle -> Maybe Handle -> IO Void
checkProcessHasNotDied Text
"cardano-node" ProcessHandle
processHandle Maybe Handle
mError) IO a
waitForNode
IO (Either Void a) -> (Either Void a -> 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
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 -> DirectBackend -> IO a
action (Value -> NominalDiffTime
getShelleyGenesisBlockTime Value
shelleyGenesis) (DirectOptions -> DirectBackend
DirectBackend (DirectOptions -> DirectBackend) -> DirectOptions -> DirectBackend
forall a b. (a -> b) -> a -> b
$ 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
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)
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)
computeBlockTime :: NominalDiffTime -> Rational -> NominalDiffTime
computeBlockTime :: NominalDiffTime -> Rational -> NominalDiffTime
computeBlockTime NominalDiffTime
slotLength Rational
activeSlotsCoeff =
NominalDiffTime
slotLength NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ Rational -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
activeSlotsCoeff
waitForFullySynchronized ::
ChainBackend backend =>
Tracer IO NodeLog ->
backend ->
IO ()
waitForFullySynchronized :: forall backend.
ChainBackend backend =>
Tracer IO NodeLog -> backend -> IO ()
waitForFullySynchronized Tracer IO NodeLog
tracer backend
backend = do
SystemStart
systemStart <- backend -> QueryPoint -> IO SystemStart
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> QueryPoint -> m SystemStart
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> QueryPoint -> m SystemStart
Backend.querySystemStart backend
backend 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 <- backend -> QueryPoint -> IO EraHistory
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> QueryPoint -> m EraHistory
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> QueryPoint -> m EraHistory
Backend.queryEraHistory backend
backend 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
<$> backend -> IO ChainPoint
forall a (m :: * -> *).
(ChainBackend a, MonadIO m, MonadThrow m) =>
a -> m ChainPoint
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
backend -> m ChainPoint
Backend.queryTip backend
backend
(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 <- backend -> (MonadIO IO, MonadThrow IO) => IO NominalDiffTime
forall a (m :: * -> *).
ChainBackend a =>
a -> (MonadIO m, MonadThrow m) => m NominalDiffTime
forall (m :: * -> *).
backend -> (MonadIO m, MonadThrow m) => m NominalDiffTime
Backend.getBlockTime backend
backend
Tracer IO NodeLog -> NodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NodeLog
tracer (NodeLog -> IO ()) -> NodeLog -> IO ()
forall a b. (a -> b) -> a -> b
$ MsgSynchronizing{Centi
$sel:percentDone:MsgNodeCmdSpec :: Centi
percentDone :: Centi
percentDone}
if NominalDiffTime
timeDifference NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
blockTime
then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
3 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SystemStart -> IO ()
check SystemStart
systemStart
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
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]
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
refreshSystemStart ::
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
mkTopology :: [Port] -> Aeson.Value
mkTopology :: [Int] -> Value
mkTopology [Int]
peers =
[Pair] -> Value
Aeson.object [Key
"Producers" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int -> Value) -> [Int] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Value
encodePeer [Int]
peers]
where
encodePeer :: Int -> Aeson.Value
encodePeer :: Int -> Value
encodePeer Int
port =
[Pair] -> Value
Aeson.object
[Key
"addr" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"127.0.0.1" :: Text), Key
"port" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
port, Key
"valency" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
1 :: Int)]
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)
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"
]
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