Fix error handling for CLI calls

src/BotPlutusInterface/CardanoCLI.hs

@@ -16,7 +16,7 @@ module BotPlutusInterface.CardanoCLI (
   queryTip,
 ) where
 
-import BotPlutusInterface.Effects (PABEffect, ShellArgs (..), callCommand, printLog, uploadDir)
+import BotPlutusInterface.Effects (PABEffect, ShellArgs (..), callCommand, uploadDir)
 import BotPlutusInterface.Files (
   DummyPrivKey (FromSKey, FromVKey),
   datumJsonFilePath,
@@ -26,10 +26,11 @@ import BotPlutusInterface.Files (
   txFilePath,
   validatorScriptFilePath,
  )
-import BotPlutusInterface.Types (LogLevel (Warn), PABConfig, Tip)
+import BotPlutusInterface.Types (PABConfig, Tip)
 import BotPlutusInterface.UtxoParser qualified as UtxoParser
 import Cardano.Api.Shelley (NetworkId (Mainnet, Testnet), NetworkMagic (..), serialiseAddress)
 import Codec.Serialise qualified as Codec
+import Control.Monad (join)
 import Control.Monad.Freer (Eff, Member)
 import Data.Aeson qualified as JSON
 import Data.Aeson.Extras (encodeByteString)
@@ -110,7 +111,7 @@ queryTip ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   PABConfig ->
-  Eff effs Tip
+  Eff effs (Either Text Tip)
 queryTip config =
   callCommand @w
     ShellArgs
@@ -125,7 +126,7 @@ utxosAt ::
   Member (PABEffect w) effs =>
   PABConfig ->
   Address ->
-  Eff effs (Map TxOutRef ChainIndexTxOut)
+  Eff effs (Either Text (Map TxOutRef ChainIndexTxOut))
 utxosAt pabConf address =
   callCommand @w
     ShellArgs
@@ -151,17 +152,18 @@ calculateMinUtxo ::
   TxOut ->
   Eff effs (Either Text Integer)
 calculateMinUtxo pabConf datums txOut =
-  callCommand @w
-    ShellArgs
-      { cmdName = "cardano-cli"
-      , cmdArgs =
-          mconcat
-            [ ["transaction", "calculate-min-required-utxo", "--alonzo-era"]
-            , txOutOpts pabConf datums [txOut]
-            , ["--protocol-params-file", pabConf.pcProtocolParamsFile]
-            ]
-      , cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
-      }
+  join
+    <$> callCommand @w
+      ShellArgs
+        { cmdName = "cardano-cli"
+        , cmdArgs =
+            mconcat
+              [ ["transaction", "calculate-min-required-utxo", "--alonzo-era"]
+              , txOutOpts pabConf datums [txOut]
+              , ["--protocol-params-file", pabConf.pcProtocolParamsFile]
+              ]
+        , cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
+        }
 
 -- | Calculating fee for an unbalanced transaction
 calculateMinFee ::
@@ -171,21 +173,22 @@ calculateMinFee ::
   Tx ->
   Eff effs (Either Text Integer)
 calculateMinFee pabConf tx =
-  callCommand @w
-    ShellArgs
-      { cmdName = "cardano-cli"
-      , cmdArgs =
-          mconcat
-            [ ["transaction", "calculate-min-fee"]
-            , ["--tx-body-file", txFilePath pabConf "raw" tx]
-            , ["--tx-in-count", showText $ length $ txInputs tx]
-            , ["--tx-out-count", showText $ length $ txOutputs tx]
-            , ["--witness-count", showText $ length $ txSignatures tx]
-            , ["--protocol-params-file", pabConf.pcProtocolParamsFile]
-            , networkOpt pabConf
-            ]
-      , cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
-      }
+  join
+    <$> callCommand @w
+      ShellArgs
+        { cmdName = "cardano-cli"
+        , cmdArgs =
+            mconcat
+              [ ["transaction", "calculate-min-fee"]
+              , ["--tx-body-file", txFilePath pabConf "raw" tx]
+              , ["--tx-in-count", showText $ length $ txInputs tx]
+              , ["--tx-out-count", showText $ length $ txOutputs tx]
+              , ["--witness-count", showText $ length $ txSignatures tx]
+              , ["--protocol-params-file", pabConf.pcProtocolParamsFile]
+              , networkOpt pabConf
+              ]
+        , cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
+        }
 
 data BuildMode = BuildRaw Integer | BuildAuto
   deriving stock (Show)
@@ -203,7 +206,7 @@ buildTx ::
   PubKeyHash ->
   BuildMode ->
   Tx ->
-  Eff effs ()
+  Eff effs (Either Text ())
 buildTx pabConf privKeys ownPkh buildMode tx =
   callCommand @w $ ShellArgs "cardano-cli" opts (const ())
   where
@@ -248,25 +251,11 @@ signTx ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   PABConfig ->
-  Map PubKeyHash DummyPrivKey ->
   Tx ->
   [PubKey] ->
   Eff effs (Either Text ())
-signTx pabConf privKeys tx pubKeys =
-  let skeys = Map.filter (\case FromSKey _ -> True; FromVKey _ -> False) privKeys
-   in if all ((`Map.member` skeys) . Ledger.pubKeyHash) pubKeys
-        then callCommand @w $ ShellArgs "cardano-cli" opts (const (Right ()))
-        else do
-          let err =
-                Text.unlines
-                  [ "Not all required signatures have signing key files. Please sign and submit the tx manually:"
-                  , "Tx file: " <> txFilePath pabConf "raw" tx
-                  , "Signatories (pkh): "
-                      <> Text.unwords
-                        (map (encodeByteString . fromBuiltin . getPubKeyHash . Ledger.pubKeyHash) pubKeys)
-                  ]
-          printLog @w Warn (Text.unpack err)
-          pure $ Left err
+signTx pabConf tx pubKeys =
+  callCommand @w $ ShellArgs "cardano-cli" opts (const ())
   where
     signingKeyFiles =
       concatMap
@@ -287,7 +276,7 @@ submitTx ::
   Member (PABEffect w) effs =>
   PABConfig ->
   Tx ->
-  Eff effs (Maybe Text)
+  Eff effs (Either Text ())
 submitTx pabConf tx =
   callCommand @w $
     ShellArgs
@@ -298,13 +287,7 @@ submitTx pabConf tx =
           , networkOpt pabConf
           ]
       )
-      ( ( \out ->
-            if "Transaction successfully submitted." `Text.isPrefixOf` out
-              then Nothing
-              else Just out
-        )
-          . Text.pack
-      )
+      (const ())
 
 txInOpts :: PABConfig -> BuildMode -> Set TxIn -> [Text]
 txInOpts pabConf buildMode =

src/BotPlutusInterface/Contract.hs

@@ -13,22 +13,28 @@ import BotPlutusInterface.Effects (
   queryChainIndex,
   threadDelay,
  )
+import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey))
 import BotPlutusInterface.Files qualified as Files
 import BotPlutusInterface.PreBalance qualified as PreBalance
-import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug), Tip (slot))
+import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug, Warn), Tip (slot))
 import Control.Lens ((^.))
+import Control.Monad (void)
 import Control.Monad.Freer (Eff, Member, interpret, reinterpret, runM, subsume, type (~>))
 import Control.Monad.Freer.Error (runError)
 import Control.Monad.Freer.Extras.Log (handleLogIgnore)
 import Control.Monad.Freer.Extras.Modify (raiseEnd)
 import Control.Monad.Freer.Writer (Writer (Tell))
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Either (eitherT, firstEitherT, newEitherT, secondEitherT)
 import Data.Aeson (ToJSON, Value)
-import Data.Either (isRight)
+import Data.Aeson.Extras (encodeByteString)
 import Data.Kind (Type)
 import Data.Map qualified as Map
 import Data.Row (Row)
+import Data.Text (Text)
 import Data.Text qualified as Text
 import Ledger (POSIXTime)
+import Ledger qualified
 import Ledger.Address (PaymentPubKeyHash (PaymentPubKeyHash))
 import Ledger.Constraints.OffChain (UnbalancedTx (..))
 import Ledger.Slot (Slot (Slot))
@@ -45,6 +51,7 @@ import Plutus.Contract.Effects (
  )
 import Plutus.Contract.Resumable (Resumable (..))
 import Plutus.Contract.Types (Contract (..), ContractEffs)
+import PlutusTx.Builtins (fromBuiltin)
 import Wallet.Emulator.Error (WalletAPIError (..))
 import Prelude
 
@@ -180,33 +187,37 @@ writeBalancedTx ::
   Eff effs WriteBalancedTxResponse
 writeBalancedTx _ (Left _) = error "Cannot handle cardano api tx"
 writeBalancedTx contractEnv (Right tx) = do
-  createDirectoryIfMissing @w False (Text.unpack contractEnv.cePABConfig.pcScriptFileDir)
+  let pabConf = contractEnv.cePABConfig
+  createDirectoryIfMissing @w False (Text.unpack pabConf.pcScriptFileDir)
 
-  fileWriteRes <-
-    Files.writeAll @w contractEnv.cePABConfig tx
+  eitherT (pure . WriteBalancedTxFailed . OtherError) (pure . WriteBalancedTxSuccess . Right) $ do
+    void $ firstEitherT (Text.pack . show) $ newEitherT $ Files.writeAll @w pabConf tx
+    privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf
 
-  case fileWriteRes of
-    Left err ->
-      pure $
-        WriteBalancedTxFailed $
-          OtherError $
-            "Failed to write script file(s): " <> Text.pack (show err)
-    Right _ -> do
-      let ownPkh = contractEnv.cePABConfig.pcOwnPubKeyHash
-      let requiredSigners = Map.keys $ tx ^. Tx.signatures
-      privKeys <- either (error . Text.unpack) id <$> Files.readPrivateKeys @w contractEnv.cePABConfig
+    let ownPkh = pabConf.pcOwnPubKeyHash
+    let requiredSigners = Map.keys $ tx ^. Tx.signatures
+    let skeys = Map.filter (\case FromSKey _ -> True; FromVKey _ -> False) privKeys
+    let signable = all ((`Map.member` skeys) . Ledger.pubKeyHash) requiredSigners
+
+    lift $ CardanoCLI.uploadFiles @w pabConf
 
-      CardanoCLI.uploadFiles @w contractEnv.cePABConfig
+    newEitherT $ CardanoCLI.buildTx @w pabConf privKeys ownPkh CardanoCLI.BuildAuto tx
 
-      CardanoCLI.buildTx @w contractEnv.cePABConfig privKeys ownPkh CardanoCLI.BuildAuto tx
-      res <- CardanoCLI.signTx @w contractEnv.cePABConfig privKeys tx requiredSigners
+    if signable
+      then newEitherT $ CardanoCLI.signTx @w pabConf tx requiredSigners
+      else
+        lift . printLog @w Warn . Text.unpack . Text.unlines $
+          [ "Not all required signatures have signing key files. Please sign and submit the tx manually:"
+          , "Tx file: " <> Files.txFilePath pabConf "raw" tx
+          , "Signatories (pkh): " <> Text.unwords (map pkhToText requiredSigners)
+          ]
 
-      result <-
-        if contractEnv.cePABConfig.pcDryRun || isRight res
-          then pure Nothing
-          else CardanoCLI.submitTx @w contractEnv.cePABConfig tx
+    if not pabConf.pcDryRun && signable
+      then secondEitherT (const tx) $ newEitherT $ CardanoCLI.submitTx @w pabConf tx
+      else pure tx
 
-      pure $ maybe (WriteBalancedTxSuccess (Right tx)) (WriteBalancedTxFailed . OtherError) result
+pkhToText :: Ledger.PubKey -> Text
+pkhToText = encodeByteString . fromBuiltin . Ledger.getPubKeyHash . Ledger.pubKeyHash
 
 {- | Wait at least until the given slot. The slot number only changes when a new block is appended
  to the chain so it waits for at least one block
@@ -219,10 +230,11 @@ awaitSlot ::
   Eff effs Slot
 awaitSlot contractEnv s@(Slot n) = do
   threadDelay @w 10_000_000
-  tip' <- CardanoCLI.queryTip @w contractEnv.cePABConfig
-  if tip'.slot < n
-    then awaitSlot contractEnv s
-    else pure $ Slot tip'.slot
+  tip <- CardanoCLI.queryTip @w contractEnv.cePABConfig
+  case tip of
+    Right tip'
+      | n < tip'.slot -> pure $ Slot tip'.slot
+    _ -> awaitSlot contractEnv s
 
 {- | Wait at least until the given time. Uses the awaitSlot under the hood, so the same constraints
  are applying here as well.
@@ -244,7 +256,7 @@ currentSlot ::
   ContractEnvironment w ->
   Eff effs Slot
 currentSlot contractEnv =
-  Slot . slot <$> CardanoCLI.queryTip @w contractEnv.cePABConfig
+  Slot . slot . either (error . Text.unpack) id <$> CardanoCLI.queryTip @w contractEnv.cePABConfig
 
 currentTime ::
   forall (w :: Type) (effs :: [Type -> Type]).

src/BotPlutusInterface/Effects.hs

@@ -35,13 +35,15 @@ import Control.Monad (void, when)
 import Control.Monad.Freer (Eff, LastMember, Member, interpretM, send, type (~>))
 import Data.Aeson (ToJSON)
 import Data.Aeson qualified as JSON
+import Data.Bifunctor (second)
 import Data.Kind (Type)
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Plutus.Contract.Effects (ChainIndexQuery, ChainIndexResponse)
 import Plutus.PAB.Core.ContractInstance.STM (Activity)
 import System.Directory qualified as Directory
-import System.Process (readProcess)
+import System.Exit (ExitCode (ExitFailure, ExitSuccess))
+import System.Process (readProcess, readProcessWithExitCode)
 import Prelude hiding (readFile)
 
 data ShellArgs a = ShellArgs
@@ -54,7 +56,7 @@ instance Show (ShellArgs a) where
   show ShellArgs {cmdName, cmdArgs} = Text.unpack $ cmdName <> mconcat cmdArgs
 
 data PABEffect (w :: Type) (r :: Type) where
-  CallCommand :: ShellArgs a -> PABEffect w a
+  CallCommand :: ShellArgs a -> PABEffect w (Either Text a)
   CreateDirectoryIfMissing :: Bool -> FilePath -> PABEffect w ()
   PrintLog :: LogLevel -> String -> PABEffect w ()
   UpdateInstanceState :: Activity -> PABEffect w ()
@@ -119,28 +121,37 @@ printLog' :: LogLevel -> LogLevel -> String -> IO ()
 printLog' logLevelSetting msgLogLvl msg =
   when (logLevelSetting >= msgLogLvl) $ putStrLn msg
 
-callLocalCommand :: forall (a :: Type). ShellArgs a -> IO a
+callLocalCommand :: forall (a :: Type). ShellArgs a -> IO (Either Text a)
 callLocalCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} =
-  cmdOutParser <$> readProcess (Text.unpack cmdName) (map Text.unpack cmdArgs) ""
+  second cmdOutParser <$> readProcessEither (Text.unpack cmdName) (map Text.unpack cmdArgs)
 
-callRemoteCommand :: forall (a :: Type). Text -> ShellArgs a -> IO a
+callRemoteCommand :: forall (a :: Type). Text -> ShellArgs a -> IO (Either Text a)
 callRemoteCommand ipAddr ShellArgs {cmdName, cmdArgs, cmdOutParser} =
-  cmdOutParser
-    <$> readProcess
+  second cmdOutParser
+    <$> readProcessEither
       "ssh"
       (map Text.unpack [ipAddr, Text.unwords $ "source ~/.bash_profile;" : cmdName : map quotes cmdArgs])
-      ""
+
 quotes :: Text -> Text
 quotes str = "\"" <> str <> "\""
 
+readProcessEither :: FilePath -> [String] -> IO (Either Text String)
+readProcessEither path args =
+  mapToEither <$> readProcessWithExitCode path args ""
+  where
+    mapToEither :: (ExitCode, String, String) -> Either Text String
+    mapToEither (ExitSuccess, stdout, _) = Right stdout
+    mapToEither (ExitFailure exitCode, _, stderr) =
+      Left $ "ExitCode " <> Text.pack (show exitCode) <> ": " <> Text.pack stderr
+
 -- Couldn't use the template haskell makeEffect here, because it caused an OverlappingInstances problem.
 -- For some reason, we need to manually propagate the @w@ type variable to @send@
 
 callCommand ::
   forall (w :: Type) (a :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   ShellArgs a ->
-  Eff effs a
+  Eff effs (Either Text a)
 callCommand = send @(PABEffect w) . CallCommand
 
 createDirectoryIfMissing ::

src/BotPlutusInterface/PreBalance.hs

@@ -70,7 +70,7 @@ preBalanceTxIO ::
 preBalanceTxIO pabConf ownPkh unbalancedTx =
   runEitherT $
     do
-      utxos <- lift $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
+      utxos <- newEitherT $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
       privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf
       let utxoIndex = fmap Tx.toTxOut utxos <> fmap (Ledger.toTxOut . fromScriptOutput) (unBalancedTxUtxoIndex unbalancedTx)
           requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx)
@@ -106,7 +106,7 @@ preBalanceTxIO pabConf ownPkh unbalancedTx =
         hoistEither $ preBalanceTx pabConf.pcProtocolParams minUtxos 0 utxoIndex ownPkh privKeys requiredSigs tx
 
       lift $ createDirectoryIfMissing @w False (Text.unpack pabConf.pcTxFileDir)
-      lift $ CardanoCLI.buildTx @w pabConf privKeys ownPkh (CardanoCLI.BuildRaw 0) txWithoutFees
+      newEitherT $ CardanoCLI.buildTx @w pabConf privKeys ownPkh (CardanoCLI.BuildRaw 0) txWithoutFees
       fees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees
 
       lift $ printLog @w Debug $ "Fees: " ++ show fees