diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 744202b5..08e80a17 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -7,7 +7,7 @@ module BotPlutusInterface.Balance ( ) where import BotPlutusInterface.CardanoCLI qualified as CardanoCLI -import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissing, printLog) +import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissingCLI, printLog) import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey) import BotPlutusInterface.Files qualified as Files import BotPlutusInterface.Types (LogLevel (Debug), PABConfig) @@ -82,6 +82,9 @@ balanceTxIO pabConf ownPkh unbalancedTx = lift $ printLog @w Debug $ show utxoIndex + -- We need this folder on the CLI machine, which may not be the local machine + lift $ createDirectoryIfMissingCLI @w False (Text.unpack pabConf.pcTxFileDir) + -- Adds required collaterals, only needs to happen once -- Also adds signatures for fee calculation preBalancedTx <- hoistEither $ addTxCollaterals utxoIndex tx >>= addSignatories ownPkh privKeys requiredSigs @@ -125,7 +128,6 @@ balanceTxIO pabConf ownPkh unbalancedTx = txWithoutFees <- hoistEither $ balanceTxStep minUtxos utxoIndex ownPkh $ tx `withFee` 0 - lift $ createDirectoryIfMissing @w False (Text.unpack pabConf.pcTxFileDir) newEitherT $ CardanoCLI.buildTx @w pabConf privKeys txWithoutFees fees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees diff --git a/src/BotPlutusInterface/CardanoCLI.hs b/src/BotPlutusInterface/CardanoCLI.hs index fea3ba04..62ee090b 100644 --- a/src/BotPlutusInterface/CardanoCLI.hs +++ b/src/BotPlutusInterface/CardanoCLI.hs @@ -7,7 +7,6 @@ module BotPlutusInterface.CardanoCLI ( calculateMinFee, buildTx, signTx, - uploadFiles, validatorScriptFilePath, unsafeSerialiseAddress, policyScriptFilePath, @@ -15,7 +14,7 @@ module BotPlutusInterface.CardanoCLI ( queryTip, ) where -import BotPlutusInterface.Effects (PABEffect, ShellArgs (..), callCommand, uploadDir) +import BotPlutusInterface.Effects (PABEffect, ShellArgs (..), callCommand) import BotPlutusInterface.Files ( DummyPrivKey (FromSKey, FromVKey), datumJsonFilePath, @@ -93,19 +92,6 @@ import Plutus.V1.Ledger.Api qualified as Plutus import PlutusTx.Builtins (fromBuiltin) import Prelude --- | Upload script files to remote server -uploadFiles :: - forall (w :: Type) (effs :: [Type -> Type]). - Member (PABEffect w) effs => - PABConfig -> - Eff effs () -uploadFiles pabConf = - mapM_ - (uploadDir @w) - [ pabConf.pcScriptFileDir - , pabConf.pcSigningKeyFileDir - ] - -- | Getting information of the latest block queryTip :: forall (w :: Type) (effs :: [Type -> Type]). diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index 885dce33..4868eec0 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/src/BotPlutusInterface/Contract.hs @@ -13,6 +13,7 @@ import BotPlutusInterface.Effects ( printLog, queryChainIndex, threadDelay, + uploadDir, ) import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey)) import BotPlutusInterface.Files qualified as Files @@ -170,10 +171,12 @@ balanceTx :: UnbalancedTx -> Eff effs BalanceTxResponse balanceTx contractEnv unbalancedTx = do + let pabConf = contractEnv.cePABConfig + uploadDir @w pabConf.pcSigningKeyFileDir eitherPreBalancedTx <- PreBalance.balanceTxIO @w - contractEnv.cePABConfig - (contractEnv.cePABConfig.pcOwnPubKeyHash) + pabConf + pabConf.pcOwnPubKeyHash unbalancedTx pure $ either (BalanceTxFailed . InsufficientFunds) (BalanceTxSuccess . Right) eitherPreBalancedTx @@ -188,18 +191,19 @@ writeBalancedTx :: writeBalancedTx _ (Left _) = error "Cannot handle cardano api tx" writeBalancedTx contractEnv (Right tx) = do let pabConf = contractEnv.cePABConfig + uploadDir @w pabConf.pcSigningKeyFileDir createDirectoryIfMissing @w False (Text.unpack pabConf.pcScriptFileDir) eitherT (pure . WriteBalancedTxFailed . OtherError) (pure . WriteBalancedTxSuccess . Right) $ do void $ firstEitherT (Text.pack . show) $ newEitherT $ Files.writeAll @w pabConf tx + lift $ uploadDir @w pabConf.pcScriptFileDir + privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf let requiredSigners = Map.keys $ tx ^. Tx.signatures skeys = Map.filter (\case FromSKey _ -> True; FromVKey _ -> False) privKeys signable = all ((`Map.member` skeys) . Ledger.pubKeyHash) requiredSigners - lift $ CardanoCLI.uploadFiles @w pabConf - newEitherT $ CardanoCLI.buildTx @w pabConf privKeys tx if signable diff --git a/src/BotPlutusInterface/Effects.hs b/src/BotPlutusInterface/Effects.hs index e14189be..e19d9e0e 100644 --- a/src/BotPlutusInterface/Effects.hs +++ b/src/BotPlutusInterface/Effects.hs @@ -7,6 +7,7 @@ module BotPlutusInterface.Effects ( ShellArgs (..), handlePABEffect, createDirectoryIfMissing, + createDirectoryIfMissingCLI, queryChainIndex, listDirectory, threadDelay, @@ -37,6 +38,8 @@ import Data.Aeson (ToJSON) import Data.Aeson qualified as JSON import Data.Bifunctor (second) import Data.Kind (Type) +import Data.Maybe (catMaybes) +import Data.String (IsString, fromString) import Data.Text (Text) import Data.Text qualified as Text import Plutus.Contract.Effects (ChainIndexQuery, ChainIndexResponse) @@ -58,6 +61,8 @@ instance Show (ShellArgs a) where data PABEffect (w :: Type) (r :: Type) where CallCommand :: ShellArgs a -> PABEffect w (Either Text a) CreateDirectoryIfMissing :: Bool -> FilePath -> PABEffect w () + -- Same as above but creates folder on the CLI machine, be that local or remote. + CreateDirectoryIfMissingCLI :: Bool -> FilePath -> PABEffect w () PrintLog :: LogLevel -> String -> PABEffect w () UpdateInstanceState :: Activity -> PABEffect w () LogToContract :: (ToJSON w, Monoid w) => w -> PABEffect w () @@ -93,6 +98,10 @@ handlePABEffect contractEnv = Remote ipAddr -> callRemoteCommand ipAddr shellArgs CreateDirectoryIfMissing createParents filePath -> Directory.createDirectoryIfMissing createParents filePath + CreateDirectoryIfMissingCLI createParents filePath -> + case contractEnv.cePABConfig.pcCliLocation of + Local -> Directory.createDirectoryIfMissing createParents filePath + Remote ipAddr -> createDirectoryIfMissingRemote ipAddr createParents filePath PrintLog logLevel txt -> printLog' contractEnv.cePABConfig.pcLogLevel logLevel txt UpdateInstanceState s -> do atomically $ @@ -132,8 +141,15 @@ callRemoteCommand ipAddr ShellArgs {cmdName, cmdArgs, cmdOutParser} = "ssh" (map Text.unpack [ipAddr, Text.unwords $ "source ~/.bash_profile;" : cmdName : map quotes cmdArgs]) -quotes :: Text -> Text -quotes str = "\"" <> str <> "\"" +createDirectoryIfMissingRemote :: Text -> Bool -> FilePath -> IO () +createDirectoryIfMissingRemote ipAddr createParents path = + void $ readProcessEither "ssh" $ catMaybes [Just $ Text.unpack ipAddr, Just "mkdir", pFlag, Just $ quotes path] + where + pFlag :: Maybe String + pFlag = if createParents then Just "-p" else Nothing + +quotes :: forall (a :: Type). (IsString a, Semigroup a) => a -> a +quotes str = fromString "\"" <> str <> fromString "\"" readProcessEither :: FilePath -> [String] -> IO (Either Text String) readProcessEither path args = @@ -162,6 +178,14 @@ createDirectoryIfMissing :: Eff effs () createDirectoryIfMissing createParents path = send @(PABEffect w) $ CreateDirectoryIfMissing createParents path +createDirectoryIfMissingCLI :: + forall (w :: Type) (effs :: [Type -> Type]). + Member (PABEffect w) effs => + Bool -> + FilePath -> + Eff effs () +createDirectoryIfMissingCLI createParents path = send @(PABEffect w) $ CreateDirectoryIfMissingCLI createParents path + printLog :: forall (w :: Type) (effs :: [Type -> Type]). Member (PABEffect w) effs => diff --git a/test/Spec/MockContract.hs b/test/Spec/MockContract.hs index ae808e64..aea42840 100644 --- a/test/Spec/MockContract.hs +++ b/test/Spec/MockContract.hs @@ -279,6 +279,8 @@ runPABEffectPure initState req = go (CallCommand args) = mockCallCommand args go (CreateDirectoryIfMissing createParents filePath) = mockCreateDirectoryIfMissing createParents filePath + go (CreateDirectoryIfMissingCLI createParents filePath) = + mockCreateDirectoryIfMissing createParents filePath go (PrintLog logLevel msg) = mockPrintLog logLevel msg go (UpdateInstanceState msg) = mockUpdateInstanceState msg go (LogToContract msg) = mockLogToContract msg