diff --git a/src/BotPlutusInterface/CardanoCLI.hs b/src/BotPlutusInterface/CardanoCLI.hs index 1b376574..7194befc 100644 --- a/src/BotPlutusInterface/CardanoCLI.hs +++ b/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 = diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index be551d65..6bae5367 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/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]). diff --git a/src/BotPlutusInterface/Effects.hs b/src/BotPlutusInterface/Effects.hs index ed48c5a9..e14189be 100644 --- a/src/BotPlutusInterface/Effects.hs +++ b/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,20 +121,29 @@ 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@ @@ -140,7 +151,7 @@ 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 :: diff --git a/src/BotPlutusInterface/PreBalance.hs b/src/BotPlutusInterface/PreBalance.hs index a62e95a1..e468ca9b 100644 --- a/src/BotPlutusInterface/PreBalance.hs +++ b/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 diff --git a/test/Spec/BotPlutusInterface/Contract.hs b/test/Spec/BotPlutusInterface/Contract.hs index 246614f7..fdd18463 100644 --- a/test/Spec/BotPlutusInterface/Contract.hs +++ b/test/Spec/BotPlutusInterface/Contract.hs @@ -330,7 +330,7 @@ withoutSigning = do submitTx constraints -- Building and siging the tx should include both signing keys - assertContractWithTxId contract initState $ \state outTxId -> + assertContractWithTxId contract initState $ \state outTxId -> do assertCommandHistory state [ @@ -347,6 +347,7 @@ withoutSigning = do |] ) ] + assertCommandNotCalled state "cardano-cli transaction sign" sendTokens :: Assertion sendTokens = do @@ -852,3 +853,15 @@ assertCommandHistory state = ( \(idx, expectedCmd) -> (state ^? commandHistory . ix idx) @?= Just (Text.replace "\n" " " expectedCmd) ) + +assertCommandCalled :: forall (w :: Type). MockContractState w -> Text -> Assertion +assertCommandCalled state expectedCmd = + assertBool + (Text.unpack . Text.unlines $ ["Command was not called:", expectedCmd]) + (any (Text.isInfixOf (Text.replace "\n" " " expectedCmd)) (state ^. commandHistory)) + +assertCommandNotCalled :: forall (w :: Type). MockContractState w -> Text -> Assertion +assertCommandNotCalled state expectedCmd = + assertBool + (Text.unpack . Text.unlines $ ["Command was called:", expectedCmd]) + (not (any (Text.isInfixOf (Text.replace "\n" " " expectedCmd)) (state ^. commandHistory))) diff --git a/test/Spec/MockContract.hs b/test/Spec/MockContract.hs index b934c404..0922b52a 100644 --- a/test/Spec/MockContract.hs +++ b/test/Spec/MockContract.hs @@ -303,42 +303,42 @@ runPABEffectPure initState req = mockCallCommand :: forall (w :: Type) (a :: Type). ShellArgs a -> - MockContract w a + MockContract w (Either Text a) mockCallCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} = do modify @(MockContractState w) (commandHistory %~ (cmdName <> " " <> Text.unwords cmdArgs <|)) case (cmdName, cmdArgs) of ("cardano-cli", "query" : "tip" : _) -> - cmdOutParser <$> mockQueryTip + Right . cmdOutParser <$> mockQueryTip ("cardano-cli", "query" : "utxo" : "--address" : addr : _) -> - cmdOutParser <$> mockQueryUtxo addr + Right . cmdOutParser <$> mockQueryUtxo addr ("cardano-cli", "transaction" : "calculate-min-required-utxo" : _) -> - pure $ cmdOutParser "Lovelace 50" + pure $ Right $ cmdOutParser "Lovelace 50" ("cardano-cli", "transaction" : "calculate-min-fee" : _) -> - pure $ cmdOutParser "200 Lovelace" + pure $ Right $ cmdOutParser "200 Lovelace" ("cardano-cli", "transaction" : "build-raw" : args) -> do case drop 1 $ dropWhile (/= "--out-file") args of filepath : _ -> modify @(MockContractState w) (files . at (Text.unpack filepath) ?~ OtherFile "TxBody") _ -> throwError @Text "Out file argument is missing" - pure $ cmdOutParser "" + pure $ Right $ cmdOutParser "" ("cardano-cli", "transaction" : "build" : args) -> do case drop 1 $ dropWhile (/= "--out-file") args of filepath : _ -> modify @(MockContractState w) (files . at (Text.unpack filepath) ?~ OtherFile "TxBody") _ -> throwError @Text "Out file argument is missing" - pure $ cmdOutParser "" + pure $ Right $ cmdOutParser "" ("cardano-cli", "transaction" : "sign" : args) -> do case drop 1 $ dropWhile (/= "--out-file") args of filepath : _ -> modify @(MockContractState w) (files . at (Text.unpack filepath) ?~ OtherFile "Tx") _ -> throwError @Text "Out file argument is missing" - pure $ cmdOutParser "" + pure $ Right $ cmdOutParser "" ("cardano-cli", "transaction" : "submit" : _) -> - pure $ cmdOutParser "" + pure $ Right $ cmdOutParser "" (unsupportedCmd, unsupportedArgs) -> throwError @Text ("Unsupported command: " <> Text.intercalate " " (unsupportedCmd : unsupportedArgs))