Skip to content

Commit

Permalink
Use ClusterM in configurePool, withRelayNode and withCardanoProcess
Browse files Browse the repository at this point in the history
  • Loading branch information
@paolino
paolino committed May 3, 2024
1 parent c7ec53e commit 53c4d1c
Show file tree
Hide file tree
Showing 4 changed files with 132 additions and 134 deletions.
15 changes: 6 additions & 9 deletions lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Cluster.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -182,9 +182,7 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config
configuredPools <- configurePools metadataServer cfgStakePools

addGenesisPools <- do
genesisDeltas <-
liftIO
$ mapM registerViaShelleyGenesis configuredPools
genesisDeltas <- mapM registerViaShelleyGenesis configuredPools
pure $ foldr (.) id genesisDeltas
-- TODO (yura): Use Faucet API isntead of these fixed addresses
faucetAddresses <-
Expand All @@ -210,8 +208,8 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config
pool0port
cfgNodeLogging
cfgNodeOutputFile
liftIO $ operatePool pool0 pool0Cfg $ \runningPool0 ->
runClusterM config $ do
operatePool pool0 pool0Cfg $ \runningPool0 ->
do
extraClusterSetupUsingNode configuredPools runningPool0
case NE.nonEmpty otherPools of
Nothing -> liftIO $ onClusterStart runningPool0
Expand All @@ -238,7 +236,7 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config
$ \_poolNode ->
withRelayNode
relayNodeParams
onClusterStart
$ liftIO . onClusterStart
where
FaucetFunds pureAdaFunds maryAllegraFunds massiveWalletFunds
= faucetFunds
Expand All @@ -256,8 +254,7 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config
-- integration tests, the integration tests /will fail/ (c.f. #3440).
-- Later setup is less sensitive. Using a wallet with retrying
-- submission pool might also be an idea for the future.
liftIO
$ forM_ configuredPools
forM_ configuredPools
$ \pool -> finalizeShelleyGenesisSetup pool runningNode

sendFaucetAssetsTo conn 20 maryAllegraFunds
Expand Down Expand Up @@ -320,7 +317,7 @@ withCluster config@Config{..} faucetFunds onClusterStart = runClusterM config
$ \(configuredPool, (port, peers)) -> do
async $ handle onException $ do
let cfg = mkConfig (port, peers)
liftIO $ operatePool configuredPool cfg $ \runningPool -> do
operatePool configuredPool cfg $ \runningPool -> do
writeChan waitGroup $ Right runningPool
readChan doneGroup
mapM_ link asyncs
Expand Down
236 changes: 115 additions & 121 deletions lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/ConfiguredPool.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-missing-local-signatures #-}

module Cardano.Wallet.Launch.Cluster.ConfiguredPool
( ConfiguredPool (..)
Expand Down Expand Up @@ -177,17 +178,18 @@ data ConfiguredPool = ConfiguredPool
{ operatePool
:: forall a
. NodeParams
-> (RunningNode -> IO a)
-> IO a
-> (RunningNode -> ClusterM a)
-> ClusterM a
-- ^ Precondition: the pool must first be registered.
, metadataUrl
:: Text
, recipe
:: PoolRecipe
-- ^ The 'PoolRecipe' used to create this 'ConfiguredPool'.
, registerViaShelleyGenesis
:: IO (ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto)
, finalizeShelleyGenesisSetup :: RunningNode -> IO ()
:: ClusterM
(ShelleyGenesis StandardCrypto -> ShelleyGenesis StandardCrypto)
, finalizeShelleyGenesisSetup :: RunningNode -> ClusterM ()
-- ^ Submit any pool retirement certificate according to the 'recipe'
-- on-chain.
}
Expand Down Expand Up @@ -431,9 +433,10 @@ configurePool
-> PoolRecipe
-> ClusterM ConfiguredPool
configurePool metadataServer recipe = do
let PoolRecipe pledgeAmt i mretirementEpoch metadata _ _ = recipe

UnliftClusterM withConfig Config{..} <- askUnliftClusterM

let PoolRecipe pledgeAmt i mRetirementEpoch metadata _ _ = recipe
liftIO $ registerMetadataForPoolIndex metadataServer i metadata
-- Use pool-specific dir
let name = "pool-" <> show i
nodeRelativePath :: RelDir
Expand All @@ -450,121 +453,112 @@ configurePool metadataServer recipe = do
let ownerPrv = FileOf @"stake-prv" $ poolDir </> relFile "stake.prv"
genStakeAddrKeyPair (ownerPrv, ownerPub)

let metadataURL = urlFromPoolIndex metadataServer i
liftIO $ registerMetadataForPoolIndex metadataServer i metadata
let metadataUrl = T.pack $ urlFromPoolIndex metadataServer i
let metadataBytes = Aeson.encode metadata
pure
ConfiguredPool
{ operatePool = \nodeParams action -> do
let NodeParams
genesisFiles
hardForks
(port, peers)
logCfg
nodeOutput = nodeParams
let logCfg' = setLoggingName name logCfg

topology <- withConfig $ genTopology nodeRelativePath peers
withStaticServer (toFilePath poolDir) $ \url -> do
traceWith cfgTracer $ MsgStartedStaticServer url poolDirPath

(nodeConfig, genesisData, vd) <-
withConfig
$ genNodeConfig
nodeRelativePath
(Tagged @"node-name" mempty)
genesisFiles
hardForks
logCfg'

let
cfg =
CardanoNodeConfig
{ nodeDir = toFilePath poolDir
, nodeConfigFile = absFilePathOf nodeConfig
, nodeTopologyFile = absFilePathOf topology
, nodeDatabaseDir = toFilePath
$ poolDir </> relDir "db"
, nodeDlgCertFile = Nothing
, nodeSignKeyFile = Nothing
, nodeOpCertFile = Just $ absFilePathOf opCert
, nodeKesKeyFile = Just $ absFilePathOf kesPrv
, nodeVrfKeyFile = Just $ absFilePathOf vrfPrv
, nodePort = Just (NodePort port)
, nodeLoggingHostname = Just name
, nodeExecutable = Nothing
, nodeOutputFile = absFilePathOf <$> nodeOutput
}

registerViaShelleyGenesis = do
poolId <- stakePoolIdFromOperatorVerKey opPub
vrf <- poolVrfFromFile vrfPub
stakePubHash <- stakingKeyHashFromFile ownerPub
pledgeAddr <- stakingAddrFromVkFile ownerPub

let params =
Ledger.PoolParams
{ ppId = poolId
, ppVrf = vrf
, ppPledge = Ledger.Coin $ intCast pledgeAmt
, ppCost = Ledger.Coin 0
, ppMargin = unsafeUnitInterval 0.1
, ppRewardAcnt =
Ledger.RewardAcnt Testnet
$ Ledger.KeyHashObj stakePubHash
, ppOwners = Set.fromList [stakePubHash]
, ppRelays = mempty
, ppMetadata =
SJust
$ Ledger.PoolMetadata
( fromMaybe (error "invalid url (too long)")
$ textToUrl 128 metadataUrl
)
(blake2b256 (BL.toStrict metadataBytes))
}
let updateStaking sgs =
sgs
{ Ledger.sgsPools =
ListMap.ListMap [(poolId, params)] <> sgsPools sgs
, Ledger.sgsStake =
ListMap.fromList [(stakePubHash, poolId)]
<> Ledger.sgsStake sgs
}
let poolSpecificFunds =
ListMap.fromList
[(pledgeAddr, Ledger.Coin $ intCast pledgeAmt)]
pure
$ over #sgInitialFunds (poolSpecificFunds <>)
. over #sgStaking updateStaking

finalizeShelleyGenesisSetup (RunningNode socket _ _) = do
-- Here is our chance to respect the 'retirementEpoch' of
-- the 'PoolRecipe'.
--
-- NOTE: We also submit the retirement cert in
-- @registerViaTx@, but this seems to work regardless. (We
-- do want to submit it here for the sake of babbage)
let retire e = do
retCert <- issuePoolRetirementCert nodeRelativePath opPub e
(rawTx, faucetPrv) <-
preparePoolRetirement
nodeRelativePath
[retCert]
signAndSubmitTx
socket
(changeFileOf @"retirement-tx" @"tx-body" rawTx)
[ changeFileOf @"faucet-prv" @"signing-key" faucetPrv
, changeFileOf @"stake-prv" @"signing-key" ownerPrv
, changeFileOf @"op-prv" @"signing-key" opPrv
]
"retirement cert"
traverse_ retire mRetirementEpoch

operatePool nodeParams action = do
let NodeParams
genesisFiles
hardForks
(port, peers)
logCfg
nodeOutput = nodeParams
let logCfg' = setLoggingName name logCfg

topology <- genTopology nodeRelativePath peers
liftIO $ withStaticServer (toFilePath poolDir) $ \url -> do
traceWith cfgTracer $ MsgStartedStaticServer url poolDirPath

(nodeConfig, genesisData, vd) <-
withConfig
$ withCardanoNodeProcess name cfg
$ \socket -> action $ RunningNode socket genesisData vd
, registerViaShelleyGenesis = withConfig $ do
poolId <- stakePoolIdFromOperatorVerKey opPub
vrf <- poolVrfFromFile vrfPub
stakePubHash <- stakingKeyHashFromFile ownerPub
pledgeAddr <- stakingAddrFromVkFile ownerPub

let params =
Ledger.PoolParams
{ ppId = poolId
, ppVrf = vrf
, ppPledge = Ledger.Coin $ intCast pledgeAmt
, ppCost = Ledger.Coin 0
, ppMargin = unsafeUnitInterval 0.1
, ppRewardAcnt =
Ledger.RewardAcnt Testnet
$ Ledger.KeyHashObj stakePubHash
, ppOwners = Set.fromList [stakePubHash]
, ppRelays = mempty
, ppMetadata =
SJust
$ Ledger.PoolMetadata
( fromMaybe (error "invalid url (too long)")
$ textToUrl 128
$ T.pack metadataURL
)
(blake2b256 (BL.toStrict metadataBytes))
}

let updateStaking sgs =
sgs
{ Ledger.sgsPools =
ListMap.ListMap [(poolId, params)] <> sgsPools sgs
, Ledger.sgsStake =
ListMap.fromList [(stakePubHash, poolId)]
<> Ledger.sgsStake sgs
}
let poolSpecificFunds =
ListMap.fromList
[(pledgeAddr, Ledger.Coin $ intCast pledgeAmt)]

pure
$ over #sgInitialFunds (poolSpecificFunds <>)
. over #sgStaking updateStaking
, finalizeShelleyGenesisSetup = \(RunningNode socket _ _) -> do
-- Here is our chance to respect the 'retirementEpoch' of
-- the 'PoolRecipe'.
--
-- NOTE: We also submit the retirement cert in
-- @registerViaTx@, but this seems to work regardless. (We
-- do want to submit it here for the sake of babbage)
let retire e = do
retCert <- issuePoolRetirementCert nodeRelativePath opPub e
(rawTx, faucetPrv) <-
preparePoolRetirement
nodeRelativePath
[retCert]
signAndSubmitTx
socket
(changeFileOf @"retirement-tx" @"tx-body" rawTx)
[ changeFileOf @"faucet-prv" @"signing-key" faucetPrv
, changeFileOf @"stake-prv" @"signing-key" ownerPrv
, changeFileOf @"op-prv" @"signing-key" opPrv
]
"retirement cert"

withConfig $ traverse_ retire mretirementEpoch
, metadataUrl = T.pack metadataURL
, recipe = recipe
}
$ genNodeConfig
nodeRelativePath
(Tagged @"node-name" mempty)
genesisFiles
hardForks
logCfg'

let cfg = CardanoNodeConfig
{ nodeDir = toFilePath poolDir
, nodeConfigFile = absFilePathOf nodeConfig
, nodeTopologyFile = absFilePathOf topology
, nodeDatabaseDir = toFilePath
$ poolDir </> relDir "db"
, nodeDlgCertFile = Nothing
, nodeSignKeyFile = Nothing
, nodeOpCertFile = Just $ absFilePathOf opCert
, nodeKesKeyFile = Just $ absFilePathOf kesPrv
, nodeVrfKeyFile = Just $ absFilePathOf vrfPrv
, nodePort = Just (NodePort port)
, nodeLoggingHostname = Just name
, nodeExecutable = Nothing
, nodeOutputFile = absFilePathOf <$> nodeOutput
}
withConfig
$ withCardanoNodeProcess name cfg
$ \socket -> action $ RunningNode socket genesisData vd
pure ConfiguredPool{..}
10 changes: 8 additions & 2 deletions lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/Process.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}

module Cardano.Wallet.Launch.Cluster.Node.Process where

import Prelude
Expand All @@ -10,6 +11,8 @@ import Cardano.Launcher.Node
)
import Cardano.Wallet.Launch.Cluster.ClusterM
( ClusterM
, UnliftClusterM (UnliftClusterM)
, askUnliftClusterM
)
import Cardano.Wallet.Launch.Cluster.Config
( Config (..)
Expand All @@ -28,8 +31,11 @@ import Control.Tracer
withCardanoNodeProcess
:: String
-> CardanoNodeConfig
-> (CardanoNodeConn -> IO a)
-> (CardanoNodeConn -> ClusterM a)
-> ClusterM a
withCardanoNodeProcess name cfg f = do
Config{..} <- ask
liftIO $ withCardanoNode (contramap (MsgLauncher name) cfgTracer) cfg f
UnliftClusterM withConfig _ <- askUnliftClusterM
liftIO
$ withCardanoNode (contramap (MsgLauncher $ show name) cfgTracer) cfg
$ withConfig . f
5 changes: 3 additions & 2 deletions lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Node/Relay.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -69,7 +69,7 @@ import System.Path.Directory
withRelayNode
:: NodeParams
-- ^ Parameters used to generate config files.
-> (RunningNode -> IO a)
-> (RunningNode -> ClusterM a)
-- ^ Callback function with socket path
-> ClusterM a
withRelayNode params onClusterStart = do
Expand Down Expand Up @@ -107,5 +107,6 @@ withRelayNode params onClusterStart = do
<$> nodeParamsOutputFile params
}

let onClusterStart' socket = onClusterStart (RunningNode socket genesisData vd)
let onClusterStart' socket = onClusterStart
$ RunningNode socket genesisData vd
withCardanoNodeProcess name cfg onClusterStart'

0 comments on commit 53c4d1c

Please sign in to comment.