Merge pull request #59 from mlabs-haskell/sam/fix-remote-cli

Fix signing keys and txs folder on remote

Author: samuelWilliams99

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
 

src/BotPlutusInterface/CardanoCLI.hs

@@ -7,15 +7,14 @@ module BotPlutusInterface.CardanoCLI (
   calculateMinFee,
   buildTx,
   signTx,
-  uploadFiles,
   validatorScriptFilePath,
   unsafeSerialiseAddress,
   policyScriptFilePath,
   utxosAt,
   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]).

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

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 =>

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