Skip to content

Commit 31ff4c4

Browse files
mikekekemikekeke
authored
Merge pull request #144 from mlabs-haskell/funds-awaiting-fix
Use chain-index to wait till cluster wallets will be funded
2 parents 26ea2fc + 7b43d60 commit 31ff4c4

File tree

17 files changed

+290
-89
lines changed

17 files changed

+290
-89
lines changed

‎Makefile‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,7 @@ FOURMOLU_EXTENSIONS := -o -XTypeApplications -o -XTemplateHaskell -o -XImportQua
4242
excluded := src/Test/Plutip/Internal/Cluster.hs
4343
format:
4444
@ echo "> Formatting all .hs files"
45-
fourmolu $(FOURMOLU_EXTENSIONS) --mode inplace --check-idempotence $$(find src/ test/ plutip-server/ local-cluster/ -iregex ".*.hs" -not -path "${excluded}")
45+
fourmolu $(FOURMOLU_EXTENSIONS) --mode inplace --check-idempotence $$(find src/ test/ plutip-server/ local-cluster/ contract-execution/ -iregex ".*.hs" -not -path "${excluded}")
4646

4747
format_check:
4848
@ echo "> Checking format of all .hs files"

‎README.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,10 @@ NOTE: This branch launches local network in `Vasil`. It was tested with node `1.
4545
* [Running Contracts is REPL](./docs/interactive-plutip.md)
4646
* [Providing constant keys](./docs/constant-keys.md)
4747

48+
## Examples
49+
50+
* [Starting private network from Haskell and executing contract](./contract-execution/Main.hs)
51+
4852
## Advanced network setup
4953

5054
* [Tweaking local network](./docs/tweaking-network.md)

‎contract-execution/ExampleContracts.hs‎

Lines changed: 39 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,39 @@
1+
module ExampleContracts (
2+
ownValueToState,
3+
) where
4+
5+
import Plutus.Contract (
6+
Contract,
7+
utxosAt,
8+
)
9+
import Plutus.Contract qualified as Contract
10+
11+
import Ledger (
12+
ChainIndexTxOut,
13+
TxOutRef,
14+
Value,
15+
ciTxOutValue,
16+
)
17+
18+
import Data.Map (Map)
19+
20+
import Control.Lens ((^.))
21+
import Data.List.NonEmpty qualified as NonEmpty
22+
import Data.Monoid (Last (Last))
23+
import Data.Text (Text)
24+
import Plutus.PAB.Effects.Contract.Builtin (EmptySchema)
25+
26+
getUtxos :: Monoid m => Contract m EmptySchema Text (Map TxOutRef ChainIndexTxOut)
27+
getUtxos = do
28+
addr <- NonEmpty.head <$> Contract.ownAddresses
29+
utxosAt addr
30+
31+
ownValue :: Monoid m => Contract m EmptySchema Text Value
32+
ownValue = foldMap (^. ciTxOutValue) <$> getUtxos
33+
34+
-- this Contract fails, but state should change in expected way
35+
ownValueToState :: Contract (Last Value) EmptySchema Text Value
36+
ownValueToState = do
37+
ow <- ownValue
38+
Contract.tell (Last $ Just ow)
39+
return ow

‎contract-execution/Main.hs‎

Lines changed: 86 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,86 @@
1+
{-# LANGUAGE DerivingStrategies #-}
2+
{-# LANGUAGE ImportQualifiedPost #-}
3+
{-# LANGUAGE NumericUnderscores #-}
4+
5+
module Main (main) where
6+
7+
import Control.Monad.IO.Class (liftIO)
8+
import Control.Monad.Reader (ReaderT (ReaderT), ask)
9+
import Data.Default (def)
10+
import Data.Monoid (Last (getLast))
11+
import Data.Text.Lazy qualified as T
12+
import ExampleContracts (ownValueToState)
13+
import Test.Plutip.Config (
14+
PlutipConfig (extraConfig),
15+
)
16+
import Test.Plutip.Contract (runContract)
17+
import Test.Plutip.Internal.BotPlutusInterface.Wallet (
18+
BpiWallet,
19+
addSomeWallet,
20+
mkMainnetAddress,
21+
walletPkh,
22+
)
23+
import Test.Plutip.Internal.Cluster.Extra.Types (
24+
ExtraConfig (ecSlotLength),
25+
)
26+
import Test.Plutip.Internal.LocalCluster (
27+
startCluster,
28+
stopCluster,
29+
)
30+
import Test.Plutip.Internal.Types (
31+
ClusterEnv,
32+
ExecutionResult (contractState, outcome),
33+
nodeSocket,
34+
)
35+
import Test.Plutip.Tools.ChainIndex qualified as CI
36+
import Text.Pretty.Simple (pShow)
37+
38+
main :: IO ()
39+
main = do
40+
let slotLen = 1
41+
extraConf = def {ecSlotLength = slotLen}
42+
plutipConfig = def {extraConfig = extraConf}
43+
44+
putStrLn "Starting cluster..."
45+
(st, _) <- startCluster plutipConfig $ do
46+
w <- addSomeWallet [toAda 10]
47+
liftIO $ putStrLn "Waiting for wallets to be funded..."
48+
CI.awaitWalletFunded w slotLen
49+
50+
separate
51+
printWallet (w, 1)
52+
printNodeRelatedInfo
53+
54+
separate
55+
res <- executeContract w ownValueToState
56+
printResult res
57+
58+
separate
59+
60+
putStrLn "Stopping cluster"
61+
62+
stopCluster st
63+
where
64+
printNodeRelatedInfo = ReaderT $ \cEnv -> do
65+
putStrLn $ "Node socket: " <> show (nodeSocket cEnv)
66+
67+
separate = liftIO $ putStrLn "\n------------\n"
68+
69+
printWallet :: (BpiWallet, Int) -> ReaderT ClusterEnv IO ()
70+
printWallet (w, n) = liftIO $ do
71+
putStrLn $ "Wallet " ++ show n ++ " PKH: " ++ show (walletPkh w)
72+
putStrLn $ "Wallet " ++ show n ++ " mainnet address: " ++ show (mkMainnetAddress w)
73+
74+
toAda = (* 1_000_000)
75+
76+
executeContract wallet contract =
77+
ask >>= \cEnv -> runContract cEnv wallet contract
78+
79+
printResult res = do
80+
liftIO . putStrLn $ "Execution outcome:\n" <> pShow' (outcome res)
81+
liftIO . putStrLn $
82+
"Contract state:\n"
83+
<> pShow' (getLast $ contractState res)
84+
85+
pShow' :: Show a => a -> String
86+
pShow' = T.unpack . pShow

‎contract-execution/README.md‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
# Contract execution example
2+
3+
An example of how to start private network from Haskell and execute arbitrary contract.

‎hie.yaml‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,5 +6,7 @@ cradle:
66
component: "test-suite:plutip-tests"
77
- path: "./local-cluster/"
88
component: "exe:local-cluster"
9+
- path: "./contract-execution/"
10+
component: "exe:contract-execution"
911
- path: "./plutip-server/"
1012
component: "exe:plutip-server"

‎local-cluster/Main.hs‎

Lines changed: 8 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ import Cardano.Ledger.Slot (EpochSize (EpochSize))
99
import Control.Applicative (optional, (<**>))
1010
import Control.Monad (forM_, replicateM, void)
1111
import Control.Monad.IO.Class (liftIO)
12-
import Control.Monad.Reader (ReaderT (ReaderT), ask)
12+
import Control.Monad.Reader (ReaderT (ReaderT))
1313
import Data.Default (def)
1414
import Data.Time (NominalDiffTime)
1515
import GHC.Natural (Natural)
@@ -29,14 +29,13 @@ import Test.Plutip.Internal.BotPlutusInterface.Wallet (
2929
import Test.Plutip.Internal.Cluster.Extra.Types (
3030
ExtraConfig (ExtraConfig),
3131
)
32-
import Test.Plutip.Internal.Types (ClusterEnv, nodeSocket)
32+
import Test.Plutip.Internal.Types (nodeSocket)
3333
import Test.Plutip.LocalCluster (
34-
BpiWallet,
3534
mkMainnetAddress,
3635
startCluster,
3736
stopCluster,
3837
)
39-
import Test.Plutip.Tools.Cluster (awaitAddressFunded)
38+
import Test.Plutip.Tools.CardanoApi (awaitAddressFunded)
4039

4140
main :: IO ()
4241
main = do
@@ -47,14 +46,14 @@ main = do
4746
let ClusterConfig {numWallets, dirWallets, numUtxos, workDir, slotLength, epochSize} = config
4847
workingDir = maybe Temporary (`Fixed` False) workDir
4948

50-
exctraCong = ExtraConfig slotLength epochSize
51-
plutipConfig = def {clusterWorkingDir = workingDir, extraConfig = exctraCong}
49+
extraConf = ExtraConfig slotLength epochSize
50+
plutipConfig = def {clusterWorkingDir = workingDir, extraConfig = extraConf}
5251

5352
putStrLn "Starting cluster..."
5453
(st, _) <- startCluster plutipConfig $ do
5554
ws <- initWallets numWallets numUtxos amt dirWallets
5655
liftIO $ putStrLn "Waiting for wallets to be funded..."
57-
awaitFunds ws (ceiling slotLength)
56+
awaitFunds ws slotLength
5857

5958
separate
6059
liftIO $ forM_ (zip ws [(1 :: Int) ..]) printWallet
@@ -89,13 +88,10 @@ main = do
8988
toAda = (* 1_000_000)
9089

9190
-- waits for the last wallet to be funded
92-
awaitFunds :: [BpiWallet] -> Int -> ReaderT ClusterEnv IO ()
9391
awaitFunds ws delay = do
94-
env <- ask
9592
let lastWallet = last ws
96-
liftIO $ do
97-
putStrLn "Waiting till all wallets will be funded..."
98-
awaitAddressFunded env delay (cardanoMainnetAddress lastWallet)
93+
liftIO $ putStrLn "Waiting till all wallets will be funded..."
94+
awaitAddressFunded (cardanoMainnetAddress lastWallet) delay
9995

10096
pnumWallets :: Parser Int
10197
pnumWallets =

‎local-cluster/README.md‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -55,8 +55,10 @@ main = do
5555

5656
(st, _) <- startCluster def $ do
5757
w <- addSomeWallet [100_000_000]
58-
waitSeconds 2
58+
awaitWalletFunded w 1
5959
result <- executeContract w someContract
6060
doSomething result
6161
stopCluster st
6262
```
63+
64+
For working example see [contract-execution](../contract-execution/Main.hs).

‎plutip-server/Api.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,7 @@ server serverOptions =
6565
:<|> stopClusterHandler
6666

6767
appServer :: Env -> Server Api
68-
appServer env@(Env {options}) =
68+
appServer env@Env {options} =
6969
hoistServer api appHandler (server options)
7070
where
7171
appHandler :: forall (a :: Type). AppM a -> Handler a

‎plutip-server/Api/Handlers.hs‎

Lines changed: 18 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -5,8 +5,7 @@ module Api.Handlers (
55

66
import Cardano.Api (serialiseToCBOR)
77
import Cardano.Launcher.Node (nodeSocketFile)
8-
9-
-- import Cardano.Wallet.Shelley.Launch.Cluster (RunningNode (RunningNode))
8+
import Test.Plutip.Tools.CardanoApi qualified as Tools
109

1110
import Control.Concurrent.MVar (isEmptyMVar, putMVar, takeMVar)
1211
import Control.Monad (unless)
@@ -21,14 +20,21 @@ import Data.Text.Encoding qualified as Text
2120
import Data.Traversable (for)
2221
import System.Directory (doesFileExist)
2322
import System.FilePath (replaceFileName)
24-
import Test.Plutip.Config (PlutipConfig (extraConfig), chainIndexPort, relayNodeLogs)
23+
import Test.Plutip.Config (
24+
PlutipConfig (extraConfig),
25+
chainIndexPort,
26+
relayNodeLogs,
27+
)
2528
import Test.Plutip.Internal.BotPlutusInterface.Setup (keysDir)
26-
import Test.Plutip.Internal.BotPlutusInterface.Wallet (BpiWallet (signKey), addSomeWallet, cardanoMainnetAddress)
29+
import Test.Plutip.Internal.BotPlutusInterface.Wallet (
30+
BpiWallet (signKey),
31+
addSomeWallet,
32+
cardanoMainnetAddress,
33+
)
2734
import Test.Plutip.Internal.Cluster (RunningNode (RunningNode))
28-
import Test.Plutip.Internal.Cluster.Extra.Types (ExtraConfig (ExtraConfig))
35+
import Test.Plutip.Internal.Cluster.Extra.Types (ExtraConfig (ExtraConfig, ecSlotLength))
2936
import Test.Plutip.Internal.LocalCluster (startCluster, stopCluster)
30-
import Test.Plutip.Internal.Types (ClusterEnv (runningNode))
31-
import Test.Plutip.Tools.Cluster (awaitAddressFunded)
37+
import Test.Plutip.Internal.Types (ClusterEnv (plutipConf, runningNode))
3238
import Types (
3339
AppM,
3440
ClusterStartupFailureReason (
@@ -97,7 +103,7 @@ startClusterHandler
97103
for keysToGenerate $ \lovelaceAmounts -> do
98104
addSomeWallet (fromInteger . unLovelace <$> lovelaceAmounts)
99105
liftIO $ putStrLn "Waiting for wallets to be funded..."
100-
awaitFunds wallets 2
106+
awaitFunds wallets (ecSlotLength $ extraConfig $ plutipConf env)
101107
pure (env, wallets)
102108
getNodeSocketFile (runningNode -> RunningNode conn _ _ _) = nodeSocketFile conn
103109
getNodeConfigFile =
@@ -108,13 +114,10 @@ startClusterHandler
108114
interpret = fmap (either ClusterStartupFailure id) . runExceptT
109115

110116
-- waits for the last wallet to be funded
111-
awaitFunds :: [BpiWallet] -> Int -> ReaderT ClusterEnv IO ()
112117
awaitFunds ws delay = do
113-
env <- ask
114-
let lastWallet = last ws
115-
liftIO $ do
116-
putStrLn $ "Waiting till all wallets will be funded..."
117-
awaitAddressFunded env delay (cardanoMainnetAddress lastWallet)
118+
let lastWalletPkh = cardanoMainnetAddress $ last ws
119+
liftIO $ putStrLn "Waiting till all wallets will be funded..."
120+
Tools.awaitAddressFunded lastWalletPkh delay
118121

119122
stopClusterHandler :: StopClusterRequest -> AppM StopClusterResponse
120123
stopClusterHandler StopClusterRequest = do
@@ -125,4 +128,4 @@ stopClusterHandler StopClusterRequest = do
125128
else do
126129
statusTVar <- liftIO $ takeMVar statusMVar
127130
liftIO $ stopCluster statusTVar
128-
pure $ StopClusterSuccess
131+
pure StopClusterSuccess

0 commit comments

Comments
 (0)