Skip to content

Commit 29dba54

Browse files
author
gege251
committed
Fix error handling for CLI calls
1 parent 490e9b6 commit 29dba54

File tree

5 files changed

+77
-76
lines changed

5 files changed

+77
-76
lines changed

‎src/BotPlutusInterface/CardanoCLI.hs‎

Lines changed: 34 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ import BotPlutusInterface.Types (PABConfig)
2828
import BotPlutusInterface.UtxoParser qualified as UtxoParser
2929
import Cardano.Api.Shelley (NetworkId (Mainnet, Testnet), NetworkMagic (..), serialiseAddress)
3030
import Codec.Serialise qualified as Codec
31+
import Control.Monad (join)
3132
import Control.Monad.Freer (Eff, Member)
3233
import Data.Aeson.Extras (encodeByteString)
3334
import Data.Attoparsec.Text (parseOnly)
@@ -99,7 +100,7 @@ utxosAt ::
99100
Member (PABEffect w) effs =>
100101
PABConfig ->
101102
Address ->
102-
Eff effs (Map TxOutRef ChainIndexTxOut)
103+
Eff effs (Either Text (Map TxOutRef ChainIndexTxOut))
103104
utxosAt pabConf address =
104105
callCommand @w
105106
ShellArgs
@@ -125,17 +126,18 @@ calculateMinUtxo ::
125126
TxOut ->
126127
Eff effs (Either Text Integer)
127128
calculateMinUtxo pabConf datums txOut =
128-
callCommand @w
129-
ShellArgs
130-
{ cmdName = "cardano-cli"
131-
, cmdArgs =
132-
mconcat
133-
[ ["transaction", "calculate-min-required-utxo", "--alonzo-era"]
134-
, txOutOpts pabConf datums [txOut]
135-
, ["--protocol-params-file", pabConf.pcProtocolParamsFile]
136-
]
137-
, cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
138-
}
129+
join
130+
<$> callCommand @w
131+
ShellArgs
132+
{ cmdName = "cardano-cli"
133+
, cmdArgs =
134+
mconcat
135+
[ ["transaction", "calculate-min-required-utxo", "--alonzo-era"]
136+
, txOutOpts pabConf datums [txOut]
137+
, ["--protocol-params-file", pabConf.pcProtocolParamsFile]
138+
]
139+
, cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
140+
}
139141

140142
-- | Calculating fee for an unbalanced transaction
141143
calculateMinFee ::
@@ -145,21 +147,22 @@ calculateMinFee ::
145147
Tx ->
146148
Eff effs (Either Text Integer)
147149
calculateMinFee pabConf tx =
148-
callCommand @w
149-
ShellArgs
150-
{ cmdName = "cardano-cli"
151-
, cmdArgs =
152-
mconcat
153-
[ ["transaction", "calculate-min-fee"]
154-
, ["--tx-body-file", txFilePath pabConf "raw" tx]
155-
, ["--tx-in-count", showText $ length $ txInputs tx]
156-
, ["--tx-out-count", showText $ length $ txOutputs tx]
157-
, ["--witness-count", showText $ length $ txSignatures tx]
158-
, ["--protocol-params-file", pabConf.pcProtocolParamsFile]
159-
, networkOpt pabConf
160-
]
161-
, cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
162-
}
150+
join
151+
<$> callCommand @w
152+
ShellArgs
153+
{ cmdName = "cardano-cli"
154+
, cmdArgs =
155+
mconcat
156+
[ ["transaction", "calculate-min-fee"]
157+
, ["--tx-body-file", txFilePath pabConf "raw" tx]
158+
, ["--tx-in-count", showText $ length $ txInputs tx]
159+
, ["--tx-out-count", showText $ length $ txOutputs tx]
160+
, ["--witness-count", showText $ length $ txSignatures tx]
161+
, ["--protocol-params-file", pabConf.pcProtocolParamsFile]
162+
, networkOpt pabConf
163+
]
164+
, cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
165+
}
163166

164167
data BuildMode = BuildRaw Integer | BuildAuto
165168
deriving stock (Show)
@@ -178,7 +181,7 @@ buildTx ::
178181
PubKeyHash ->
179182
BuildMode ->
180183
Tx ->
181-
Eff effs ()
184+
Eff effs (Either Text ())
182185
buildTx pabConf ownPkh buildMode tx =
183186
callCommand @w $ ShellArgs "cardano-cli" opts (const ())
184187
where
@@ -215,7 +218,7 @@ signTx ::
215218
PABConfig ->
216219
Tx ->
217220
[PubKey] ->
218-
Eff effs ()
221+
Eff effs (Either Text ())
219222
signTx pabConf tx pubKeys =
220223
callCommand @w $
221224
ShellArgs
@@ -240,7 +243,7 @@ submitTx ::
240243
Member (PABEffect w) effs =>
241244
PABConfig ->
242245
Tx ->
243-
Eff effs (Maybe Text)
246+
Eff effs (Either Text ())
244247
submitTx pabConf tx =
245248
callCommand @w $
246249
ShellArgs
@@ -251,13 +254,7 @@ submitTx pabConf tx =
251254
, networkOpt pabConf
252255
]
253256
)
254-
( ( \out ->
255-
if "Transaction successfully submitted." `Text.isPrefixOf` out
256-
then Nothing
257-
else Just out
258-
)
259-
. Text.pack
260-
)
257+
(const ())
261258

262259
txInOpts :: PABConfig -> BuildMode -> Set TxIn -> [Text]
263260
txInOpts pabConf buildMode =

‎src/BotPlutusInterface/Contract.hs‎

Lines changed: 13 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -16,11 +16,14 @@ import BotPlutusInterface.Files qualified as Files
1616
import BotPlutusInterface.PreBalance qualified as PreBalance
1717
import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug))
1818
import Control.Lens ((^.))
19+
import Control.Monad (void)
1920
import Control.Monad.Freer (Eff, Member, interpret, reinterpret, runM, subsume, type (~>))
2021
import Control.Monad.Freer.Error (runError)
2122
import Control.Monad.Freer.Extras.Log (handleLogIgnore)
2223
import Control.Monad.Freer.Extras.Modify (raiseEnd)
2324
import Control.Monad.Freer.Writer (Writer (Tell))
25+
import Control.Monad.Trans.Class (lift)
26+
import Control.Monad.Trans.Either (eitherT, firstEitherT, newEitherT, secondEitherT)
2427
import Data.Aeson (ToJSON, Value)
2528
import Data.Kind (Type)
2629
import Data.Map qualified as Map
@@ -183,27 +186,17 @@ writeBalancedTx _ (Left _) = error "Cannot handle cardano api tx"
183186
writeBalancedTx contractEnv (Right tx) = do
184187
createDirectoryIfMissing @w False (Text.unpack contractEnv.cePABConfig.pcScriptFileDir)
185188

186-
fileWriteRes <-
187-
Files.writeAll @w contractEnv.cePABConfig tx
189+
eitherT (pure . WriteBalancedTxFailed . OtherError) (pure . WriteBalancedTxSuccess . Right) $ do
190+
void $ firstEitherT (Text.pack . show) $ newEitherT $ Files.writeAll @w contractEnv.cePABConfig tx
188191

189-
case fileWriteRes of
190-
Left err ->
191-
pure $
192-
WriteBalancedTxFailed $
193-
OtherError $
194-
"Failed to write script file(s): " <> Text.pack (show err)
195-
Right _ -> do
196-
let ownPkh = contractEnv.cePABConfig.pcOwnPubKeyHash
197-
let requiredSigners = Map.keys $ tx ^. Tx.signatures
192+
let ownPkh = contractEnv.cePABConfig.pcOwnPubKeyHash
193+
let requiredSigners = Map.keys $ tx ^. Tx.signatures
198194

199-
CardanoCLI.uploadFiles @w contractEnv.cePABConfig
195+
lift $ CardanoCLI.uploadFiles @w contractEnv.cePABConfig
200196

201-
CardanoCLI.buildTx @w contractEnv.cePABConfig ownPkh CardanoCLI.BuildAuto tx
202-
CardanoCLI.signTx @w contractEnv.cePABConfig tx requiredSigners
197+
newEitherT $ CardanoCLI.buildTx @w contractEnv.cePABConfig ownPkh CardanoCLI.BuildAuto tx
198+
newEitherT $ CardanoCLI.signTx @w contractEnv.cePABConfig tx requiredSigners
203199

204-
result <-
205-
if contractEnv.cePABConfig.pcDryRun
206-
then pure Nothing
207-
else CardanoCLI.submitTx @w contractEnv.cePABConfig tx
208-
209-
pure $ maybe (WriteBalancedTxSuccess (Right tx)) (WriteBalancedTxFailed . OtherError) result
200+
if contractEnv.cePABConfig.pcDryRun
201+
then pure tx
202+
else secondEitherT (const tx) $ newEitherT $ CardanoCLI.submitTx @w contractEnv.cePABConfig tx

‎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
@@ -61,7 +61,7 @@ preBalanceTxIO ::
6161
preBalanceTxIO pabConf ownPkh unbalancedTx =
6262
runEitherT $
6363
do
64-
utxos <- lift $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
64+
utxos <- newEitherT $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
6565
privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf
6666
let utxoIndex = fmap Tx.toTxOut utxos <> fmap (Ledger.toTxOut . fromScriptOutput) (unBalancedTxUtxoIndex unbalancedTx)
6767
tx = unBalancedTxTx unbalancedTx
@@ -92,7 +92,7 @@ preBalanceTxIO pabConf ownPkh unbalancedTx =
9292
hoistEither $ preBalanceTx pabConf.pcProtocolParams minUtxos 0 utxoIndex ownPkh privKeys requiredSigs tx
9393

9494
lift $ createDirectoryIfMissing @w False (Text.unpack pabConf.pcTxFileDir)
95-
lift $ CardanoCLI.buildTx @w pabConf ownPkh (CardanoCLI.BuildRaw 0) txWithoutFees
95+
newEitherT $ CardanoCLI.buildTx @w pabConf ownPkh (CardanoCLI.BuildRaw 0) txWithoutFees
9696
fees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees
9797

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

‎test/Spec/MockContract.hs‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -261,40 +261,40 @@ runPABEffectPure initState req =
261261
mockCallCommand ::
262262
forall (w :: Type) (a :: Type).
263263
ShellArgs a ->
264-
MockContract w a
264+
MockContract w (Either Text a)
265265
mockCallCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} = do
266266
modify @(MockContractState w) (commandHistory %~ (cmdName <> " " <> Text.unwords cmdArgs <|))
267267

268268
case (cmdName, cmdArgs) of
269269
("cardano-cli", "query" : "utxo" : "--address" : addr : _) ->
270-
cmdOutParser <$> mockQueryUtxo addr
270+
Right . cmdOutParser <$> mockQueryUtxo addr
271271
("cardano-cli", "transaction" : "calculate-min-required-utxo" : _) ->
272-
pure $ cmdOutParser "Lovelace 50"
272+
pure $ Right $ cmdOutParser "Lovelace 50"
273273
("cardano-cli", "transaction" : "calculate-min-fee" : _) ->
274-
pure $ cmdOutParser "200 Lovelace"
274+
pure $ Right $ cmdOutParser "200 Lovelace"
275275
("cardano-cli", "transaction" : "build-raw" : args) -> do
276276
case drop 1 $ dropWhile (/= "--out-file") args of
277277
filepath : _ ->
278278
modify @(MockContractState w) (files . at (Text.unpack filepath) ?~ OtherFile "TxBody")
279279
_ -> throwError @Text "Out file argument is missing"
280280

281-
pure $ cmdOutParser ""
281+
pure $ Right $ cmdOutParser ""
282282
("cardano-cli", "transaction" : "build" : args) -> do
283283
case drop 1 $ dropWhile (/= "--out-file") args of
284284
filepath : _ ->
285285
modify @(MockContractState w) (files . at (Text.unpack filepath) ?~ OtherFile "TxBody")
286286
_ -> throwError @Text "Out file argument is missing"
287287

288-
pure $ cmdOutParser ""
288+
pure $ Right $ cmdOutParser ""
289289
("cardano-cli", "transaction" : "sign" : args) -> do
290290
case drop 1 $ dropWhile (/= "--out-file") args of
291291
filepath : _ ->
292292
modify @(MockContractState w) (files . at (Text.unpack filepath) ?~ OtherFile "Tx")
293293
_ -> throwError @Text "Out file argument is missing"
294294

295-
pure $ cmdOutParser ""
295+
pure $ Right $ cmdOutParser ""
296296
("cardano-cli", "transaction" : "submit" : _) ->
297-
pure $ cmdOutParser ""
297+
pure $ Right $ cmdOutParser ""
298298
_ -> throwError @Text "Unknown command"
299299

300300
mockQueryUtxo :: forall (w :: Type). Text -> MockContract w String

0 commit comments

Comments
 (0)