Skip to content

Commit 9cf0c14

Browse files
szg251szg251
authored
Merge pull request #47 from mlabs-haskell/gergely/error-handling
Fix error handling for CLI calls
2 parents cd9bb41 + 8f8423d commit 9cf0c14

File tree

6 files changed

+123
-104
lines changed

6 files changed

+123
-104
lines changed

‎src/BotPlutusInterface/CardanoCLI.hs‎

Lines changed: 38 additions & 55 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ module BotPlutusInterface.CardanoCLI (
1616
queryTip,
1717
) where
1818

19-
import BotPlutusInterface.Effects (PABEffect, ShellArgs (..), callCommand, printLog, uploadDir)
19+
import BotPlutusInterface.Effects (PABEffect, ShellArgs (..), callCommand, uploadDir)
2020
import BotPlutusInterface.Files (
2121
DummyPrivKey (FromSKey, FromVKey),
2222
datumJsonFilePath,
@@ -26,10 +26,11 @@ import BotPlutusInterface.Files (
2626
txFilePath,
2727
validatorScriptFilePath,
2828
)
29-
import BotPlutusInterface.Types (LogLevel (Warn), PABConfig, Tip)
29+
import BotPlutusInterface.Types (PABConfig, Tip)
3030
import BotPlutusInterface.UtxoParser qualified as UtxoParser
3131
import Cardano.Api.Shelley (NetworkId (Mainnet, Testnet), NetworkMagic (..), serialiseAddress)
3232
import Codec.Serialise qualified as Codec
33+
import Control.Monad (join)
3334
import Control.Monad.Freer (Eff, Member)
3435
import Data.Aeson qualified as JSON
3536
import Data.Aeson.Extras (encodeByteString)
@@ -110,7 +111,7 @@ queryTip ::
110111
forall (w :: Type) (effs :: [Type -> Type]).
111112
Member (PABEffect w) effs =>
112113
PABConfig ->
113-
Eff effs Tip
114+
Eff effs (Either Text Tip)
114115
queryTip config =
115116
callCommand @w
116117
ShellArgs
@@ -125,7 +126,7 @@ utxosAt ::
125126
Member (PABEffect w) effs =>
126127
PABConfig ->
127128
Address ->
128-
Eff effs (Map TxOutRef ChainIndexTxOut)
129+
Eff effs (Either Text (Map TxOutRef ChainIndexTxOut))
129130
utxosAt pabConf address =
130131
callCommand @w
131132
ShellArgs
@@ -151,17 +152,18 @@ calculateMinUtxo ::
151152
TxOut ->
152153
Eff effs (Either Text Integer)
153154
calculateMinUtxo pabConf datums txOut =
154-
callCommand @w
155-
ShellArgs
156-
{ cmdName = "cardano-cli"
157-
, cmdArgs =
158-
mconcat
159-
[ ["transaction", "calculate-min-required-utxo", "--alonzo-era"]
160-
, txOutOpts pabConf datums [txOut]
161-
, ["--protocol-params-file", pabConf.pcProtocolParamsFile]
162-
]
163-
, cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
164-
}
155+
join
156+
<$> callCommand @w
157+
ShellArgs
158+
{ cmdName = "cardano-cli"
159+
, cmdArgs =
160+
mconcat
161+
[ ["transaction", "calculate-min-required-utxo", "--alonzo-era"]
162+
, txOutOpts pabConf datums [txOut]
163+
, ["--protocol-params-file", pabConf.pcProtocolParamsFile]
164+
]
165+
, cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
166+
}
165167

166168
-- | Calculating fee for an unbalanced transaction
167169
calculateMinFee ::
@@ -171,21 +173,22 @@ calculateMinFee ::
171173
Tx ->
172174
Eff effs (Either Text Integer)
173175
calculateMinFee pabConf tx =
174-
callCommand @w
175-
ShellArgs
176-
{ cmdName = "cardano-cli"
177-
, cmdArgs =
178-
mconcat
179-
[ ["transaction", "calculate-min-fee"]
180-
, ["--tx-body-file", txFilePath pabConf "raw" tx]
181-
, ["--tx-in-count", showText $ length $ txInputs tx]
182-
, ["--tx-out-count", showText $ length $ txOutputs tx]
183-
, ["--witness-count", showText $ length $ txSignatures tx]
184-
, ["--protocol-params-file", pabConf.pcProtocolParamsFile]
185-
, networkOpt pabConf
186-
]
187-
, cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
188-
}
176+
join
177+
<$> callCommand @w
178+
ShellArgs
179+
{ cmdName = "cardano-cli"
180+
, cmdArgs =
181+
mconcat
182+
[ ["transaction", "calculate-min-fee"]
183+
, ["--tx-body-file", txFilePath pabConf "raw" tx]
184+
, ["--tx-in-count", showText $ length $ txInputs tx]
185+
, ["--tx-out-count", showText $ length $ txOutputs tx]
186+
, ["--witness-count", showText $ length $ txSignatures tx]
187+
, ["--protocol-params-file", pabConf.pcProtocolParamsFile]
188+
, networkOpt pabConf
189+
]
190+
, cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
191+
}
189192

190193
data BuildMode = BuildRaw Integer | BuildAuto
191194
deriving stock (Show)
@@ -203,7 +206,7 @@ buildTx ::
203206
PubKeyHash ->
204207
BuildMode ->
205208
Tx ->
206-
Eff effs ()
209+
Eff effs (Either Text ())
207210
buildTx pabConf privKeys ownPkh buildMode tx =
208211
callCommand @w $ ShellArgs "cardano-cli" opts (const ())
209212
where
@@ -248,25 +251,11 @@ signTx ::
248251
forall (w :: Type) (effs :: [Type -> Type]).
249252
Member (PABEffect w) effs =>
250253
PABConfig ->
251-
Map PubKeyHash DummyPrivKey ->
252254
Tx ->
253255
[PubKey] ->
254256
Eff effs (Either Text ())
255-
signTx pabConf privKeys tx pubKeys =
256-
let skeys = Map.filter (\case FromSKey _ -> True; FromVKey _ -> False) privKeys
257-
in if all ((`Map.member` skeys) . Ledger.pubKeyHash) pubKeys
258-
then callCommand @w $ ShellArgs "cardano-cli" opts (const (Right ()))
259-
else do
260-
let err =
261-
Text.unlines
262-
[ "Not all required signatures have signing key files. Please sign and submit the tx manually:"
263-
, "Tx file: " <> txFilePath pabConf "raw" tx
264-
, "Signatories (pkh): "
265-
<> Text.unwords
266-
(map (encodeByteString . fromBuiltin . getPubKeyHash . Ledger.pubKeyHash) pubKeys)
267-
]
268-
printLog @w Warn (Text.unpack err)
269-
pure $ Left err
257+
signTx pabConf tx pubKeys =
258+
callCommand @w $ ShellArgs "cardano-cli" opts (const ())
270259
where
271260
signingKeyFiles =
272261
concatMap
@@ -287,7 +276,7 @@ submitTx ::
287276
Member (PABEffect w) effs =>
288277
PABConfig ->
289278
Tx ->
290-
Eff effs (Maybe Text)
279+
Eff effs (Either Text ())
291280
submitTx pabConf tx =
292281
callCommand @w $
293282
ShellArgs
@@ -298,13 +287,7 @@ submitTx pabConf tx =
298287
, networkOpt pabConf
299288
]
300289
)
301-
( ( \out ->
302-
if "Transaction successfully submitted." `Text.isPrefixOf` out
303-
then Nothing
304-
else Just out
305-
)
306-
. Text.pack
307-
)
290+
(const ())
308291

309292
txInOpts :: PABConfig -> BuildMode -> Set TxIn -> [Text]
310293
txInOpts pabConf buildMode =

‎src/BotPlutusInterface/Contract.hs‎

Lines changed: 40 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -13,22 +13,28 @@ import BotPlutusInterface.Effects (
1313
queryChainIndex,
1414
threadDelay,
1515
)
16+
import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey))
1617
import BotPlutusInterface.Files qualified as Files
1718
import BotPlutusInterface.PreBalance qualified as PreBalance
18-
import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug), Tip (slot))
19+
import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug, Warn), Tip (slot))
1920
import Control.Lens ((^.))
21+
import Control.Monad (void)
2022
import Control.Monad.Freer (Eff, Member, interpret, reinterpret, runM, subsume, type (~>))
2123
import Control.Monad.Freer.Error (runError)
2224
import Control.Monad.Freer.Extras.Log (handleLogIgnore)
2325
import Control.Monad.Freer.Extras.Modify (raiseEnd)
2426
import Control.Monad.Freer.Writer (Writer (Tell))
27+
import Control.Monad.Trans.Class (lift)
28+
import Control.Monad.Trans.Either (eitherT, firstEitherT, newEitherT, secondEitherT)
2529
import Data.Aeson (ToJSON, Value)
26-
import Data.Either (isRight)
30+
import Data.Aeson.Extras (encodeByteString)
2731
import Data.Kind (Type)
2832
import Data.Map qualified as Map
2933
import Data.Row (Row)
34+
import Data.Text (Text)
3035
import Data.Text qualified as Text
3136
import Ledger (POSIXTime)
37+
import Ledger qualified
3238
import Ledger.Address (PaymentPubKeyHash (PaymentPubKeyHash))
3339
import Ledger.Constraints.OffChain (UnbalancedTx (..))
3440
import Ledger.Slot (Slot (Slot))
@@ -45,6 +51,7 @@ import Plutus.Contract.Effects (
4551
)
4652
import Plutus.Contract.Resumable (Resumable (..))
4753
import Plutus.Contract.Types (Contract (..), ContractEffs)
54+
import PlutusTx.Builtins (fromBuiltin)
4855
import Wallet.Emulator.Error (WalletAPIError (..))
4956
import Prelude
5057

@@ -180,33 +187,37 @@ writeBalancedTx ::
180187
Eff effs WriteBalancedTxResponse
181188
writeBalancedTx _ (Left _) = error "Cannot handle cardano api tx"
182189
writeBalancedTx contractEnv (Right tx) = do
183-
createDirectoryIfMissing @w False (Text.unpack contractEnv.cePABConfig.pcScriptFileDir)
190+
let pabConf = contractEnv.cePABConfig
191+
createDirectoryIfMissing @w False (Text.unpack pabConf.pcScriptFileDir)
184192

185-
fileWriteRes <-
186-
Files.writeAll @w contractEnv.cePABConfig tx
193+
eitherT (pure . WriteBalancedTxFailed . OtherError) (pure . WriteBalancedTxSuccess . Right) $ do
194+
void $ firstEitherT (Text.pack . show) $ newEitherT $ Files.writeAll @w pabConf tx
195+
privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf
187196

188-
case fileWriteRes of
189-
Left err ->
190-
pure $
191-
WriteBalancedTxFailed $
192-
OtherError $
193-
"Failed to write script file(s): " <> Text.pack (show err)
194-
Right _ -> do
195-
let ownPkh = contractEnv.cePABConfig.pcOwnPubKeyHash
196-
let requiredSigners = Map.keys $ tx ^. Tx.signatures
197-
privKeys <- either (error . Text.unpack) id <$> Files.readPrivateKeys @w contractEnv.cePABConfig
197+
let ownPkh = pabConf.pcOwnPubKeyHash
198+
let requiredSigners = Map.keys $ tx ^. Tx.signatures
199+
let skeys = Map.filter (\case FromSKey _ -> True; FromVKey _ -> False) privKeys
200+
let signable = all ((`Map.member` skeys) . Ledger.pubKeyHash) requiredSigners
201+
202+
lift $ CardanoCLI.uploadFiles @w pabConf
198203

199-
CardanoCLI.uploadFiles @w contractEnv.cePABConfig
204+
newEitherT $ CardanoCLI.buildTx @w pabConf privKeys ownPkh CardanoCLI.BuildAuto tx
200205

201-
CardanoCLI.buildTx @w contractEnv.cePABConfig privKeys ownPkh CardanoCLI.BuildAuto tx
202-
res <- CardanoCLI.signTx @w contractEnv.cePABConfig privKeys tx requiredSigners
206+
if signable
207+
then newEitherT $ CardanoCLI.signTx @w pabConf tx requiredSigners
208+
else
209+
lift . printLog @w Warn . Text.unpack . Text.unlines $
210+
[ "Not all required signatures have signing key files. Please sign and submit the tx manually:"
211+
, "Tx file: " <> Files.txFilePath pabConf "raw" tx
212+
, "Signatories (pkh): " <> Text.unwords (map pkhToText requiredSigners)
213+
]
203214

204-
result <-
205-
if contractEnv.cePABConfig.pcDryRun || isRight res
206-
then pure Nothing
207-
else CardanoCLI.submitTx @w contractEnv.cePABConfig tx
215+
if not pabConf.pcDryRun && signable
216+
then secondEitherT (const tx) $ newEitherT $ CardanoCLI.submitTx @w pabConf tx
217+
else pure tx
208218

209-
pure $ maybe (WriteBalancedTxSuccess (Right tx)) (WriteBalancedTxFailed . OtherError) result
219+
pkhToText :: Ledger.PubKey -> Text
220+
pkhToText = encodeByteString . fromBuiltin . Ledger.getPubKeyHash . Ledger.pubKeyHash
210221

211222
{- | Wait at least until the given slot. The slot number only changes when a new block is appended
212223
to the chain so it waits for at least one block
@@ -219,10 +230,11 @@ awaitSlot ::
219230
Eff effs Slot
220231
awaitSlot contractEnv s@(Slot n) = do
221232
threadDelay @w 10_000_000
222-
tip' <- CardanoCLI.queryTip @w contractEnv.cePABConfig
223-
if tip'.slot < n
224-
then awaitSlot contractEnv s
225-
else pure $ Slot tip'.slot
233+
tip <- CardanoCLI.queryTip @w contractEnv.cePABConfig
234+
case tip of
235+
Right tip'
236+
| n < tip'.slot -> pure $ Slot tip'.slot
237+
_ -> awaitSlot contractEnv s
226238

227239
{- | Wait at least until the given time. Uses the awaitSlot under the hood, so the same constraints
228240
are applying here as well.
@@ -244,7 +256,7 @@ currentSlot ::
244256
ContractEnvironment w ->
245257
Eff effs Slot
246258
currentSlot contractEnv =
247-
Slot . slot <$> CardanoCLI.queryTip @w contractEnv.cePABConfig
259+
Slot . slot . either (error . Text.unpack) id <$> CardanoCLI.queryTip @w contractEnv.cePABConfig
248260

249261
currentTime ::
250262
forall (w :: Type) (effs :: [Type -> Type]).

‎src/BotPlutusInterface/Effects.hs‎

Lines changed: 20 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -35,13 +35,15 @@ import Control.Monad (void, when)
3535
import Control.Monad.Freer (Eff, LastMember, Member, interpretM, send, type (~>))
3636
import Data.Aeson (ToJSON)
3737
import Data.Aeson qualified as JSON
38+
import Data.Bifunctor (second)
3839
import Data.Kind (Type)
3940
import Data.Text (Text)
4041
import Data.Text qualified as Text
4142
import Plutus.Contract.Effects (ChainIndexQuery, ChainIndexResponse)
4243
import Plutus.PAB.Core.ContractInstance.STM (Activity)
4344
import System.Directory qualified as Directory
44-
import System.Process (readProcess)
45+
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
46+
import System.Process (readProcess, readProcessWithExitCode)
4547
import Prelude hiding (readFile)
4648

4749
data ShellArgs a = ShellArgs
@@ -54,7 +56,7 @@ instance Show (ShellArgs a) where
5456
show ShellArgs {cmdName, cmdArgs} = Text.unpack $ cmdName <> mconcat cmdArgs
5557

5658
data PABEffect (w :: Type) (r :: Type) where
57-
CallCommand :: ShellArgs a -> PABEffect w a
59+
CallCommand :: ShellArgs a -> PABEffect w (Either Text a)
5860
CreateDirectoryIfMissing :: Bool -> FilePath -> PABEffect w ()
5961
PrintLog :: LogLevel -> String -> PABEffect w ()
6062
UpdateInstanceState :: Activity -> PABEffect w ()
@@ -119,28 +121,37 @@ printLog' :: LogLevel -> LogLevel -> String -> IO ()
119121
printLog' logLevelSetting msgLogLvl msg =
120122
when (logLevelSetting >= msgLogLvl) $ putStrLn msg
121123

122-
callLocalCommand :: forall (a :: Type). ShellArgs a -> IO a
124+
callLocalCommand :: forall (a :: Type). ShellArgs a -> IO (Either Text a)
123125
callLocalCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} =
124-
cmdOutParser <$> readProcess (Text.unpack cmdName) (map Text.unpack cmdArgs) ""
126+
second cmdOutParser <$> readProcessEither (Text.unpack cmdName) (map Text.unpack cmdArgs)
125127

126-
callRemoteCommand :: forall (a :: Type). Text -> ShellArgs a -> IO a
128+
callRemoteCommand :: forall (a :: Type). Text -> ShellArgs a -> IO (Either Text a)
127129
callRemoteCommand ipAddr ShellArgs {cmdName, cmdArgs, cmdOutParser} =
128-
cmdOutParser
129-
<$> readProcess
130+
second cmdOutParser
131+
<$> readProcessEither
130132
"ssh"
131133
(map Text.unpack [ipAddr, Text.unwords $ "source ~/.bash_profile;" : cmdName : map quotes cmdArgs])
132-
""
134+
133135
quotes :: Text -> Text
134136
quotes str = "\"" <> str <> "\""
135137

138+
readProcessEither :: FilePath -> [String] -> IO (Either Text String)
139+
readProcessEither path args =
140+
mapToEither <$> readProcessWithExitCode path args ""
141+
where
142+
mapToEither :: (ExitCode, String, String) -> Either Text String
143+
mapToEither (ExitSuccess, stdout, _) = Right stdout
144+
mapToEither (ExitFailure exitCode, _, stderr) =
145+
Left $ "ExitCode " <> Text.pack (show exitCode) <> ": " <> Text.pack stderr
146+
136147
-- Couldn't use the template haskell makeEffect here, because it caused an OverlappingInstances problem.
137148
-- For some reason, we need to manually propagate the @w@ type variable to @send@
138149

139150
callCommand ::
140151
forall (w :: Type) (a :: Type) (effs :: [Type -> Type]).
141152
Member (PABEffect w) effs =>
142153
ShellArgs a ->
143-
Eff effs a
154+
Eff effs (Either Text a)
144155
callCommand = send @(PABEffect w) . CallCommand
145156

146157
createDirectoryIfMissing ::

‎src/BotPlutusInterface/PreBalance.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -70,7 +70,7 @@ preBalanceTxIO ::
7070
preBalanceTxIO pabConf ownPkh unbalancedTx =
7171
runEitherT $
7272
do
73-
utxos <- lift $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
73+
utxos <- newEitherT $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
7474
privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf
7575
let utxoIndex = fmap Tx.toTxOut utxos <> fmap (Ledger.toTxOut . fromScriptOutput) (unBalancedTxUtxoIndex unbalancedTx)
7676
requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx)
@@ -106,7 +106,7 @@ preBalanceTxIO pabConf ownPkh unbalancedTx =
106106
hoistEither $ preBalanceTx pabConf.pcProtocolParams minUtxos 0 utxoIndex ownPkh privKeys requiredSigs tx
107107

108108
lift $ createDirectoryIfMissing @w False (Text.unpack pabConf.pcTxFileDir)
109-
lift $ CardanoCLI.buildTx @w pabConf privKeys ownPkh (CardanoCLI.BuildRaw 0) txWithoutFees
109+
newEitherT $ CardanoCLI.buildTx @w pabConf privKeys ownPkh (CardanoCLI.BuildRaw 0) txWithoutFees
110110
fees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees
111111

112112
lift $ printLog @w Debug $ "Fees: " ++ show fees

0 commit comments

Comments
 (0)