Merge pull request #43 from mlabs-haskell/gergely/manual-sign

Add the option to manually sign transactions

Author: szg251

src/BotPlutusInterface/CardanoCLI.hs

@@ -16,16 +16,17 @@ module BotPlutusInterface.CardanoCLI (
   queryTip,
 ) where
 
-import BotPlutusInterface.Effects (PABEffect, ShellArgs (..), callCommand, uploadDir)
+import BotPlutusInterface.Effects (PABEffect, ShellArgs (..), callCommand, printLog, uploadDir)
 import BotPlutusInterface.Files (
+  DummyPrivKey (FromSKey, FromVKey),
   datumJsonFilePath,
   policyScriptFilePath,
   redeemerJsonFilePath,
   signingKeyFilePath,
   txFilePath,
   validatorScriptFilePath,
  )
-import BotPlutusInterface.Types (PABConfig, Tip)
+import BotPlutusInterface.Types (LogLevel (Warn), PABConfig, Tip)
 import BotPlutusInterface.UtxoParser qualified as UtxoParser
 import Cardano.Api.Shelley (NetworkId (Mainnet, Testnet), NetworkMagic (..), serialiseAddress)
 import Codec.Serialise qualified as Codec
@@ -54,7 +55,7 @@ import Ledger (Slot (Slot), SlotRange)
 import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Address (Address (..))
-import Ledger.Crypto (PubKey, PubKeyHash)
+import Ledger.Crypto (PubKey, PubKeyHash (getPubKeyHash))
 import Ledger.Interval (
   Extended (Finite),
   Interval (Interval),
@@ -198,17 +199,27 @@ buildTx ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   PABConfig ->
+  Map PubKeyHash DummyPrivKey ->
   PubKeyHash ->
   BuildMode ->
   Tx ->
   Eff effs ()
-buildTx pabConf ownPkh buildMode tx =
+buildTx pabConf privKeys ownPkh buildMode tx =
   callCommand @w $ ShellArgs "cardano-cli" opts (const ())
   where
     ownAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
     requiredSigners =
       concatMap
-        (\pubKey -> ["--required-signer", signingKeyFilePath pabConf (Ledger.pubKeyHash pubKey)])
+        ( \pubKey ->
+            let pkh = Ledger.pubKeyHash pubKey
+             in case Map.lookup pkh privKeys of
+                  Just (FromSKey _) ->
+                    ["--required-signer", signingKeyFilePath pabConf pkh]
+                  Just (FromVKey _) ->
+                    ["--required-signer-hash", encodeByteString $ fromBuiltin $ getPubKeyHash pkh]
+                  Nothing ->
+                    []
+        )
         (Map.keys (Ledger.txSignatures tx))
     opts =
       mconcat
@@ -237,27 +248,39 @@ signTx ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   PABConfig ->
+  Map PubKeyHash DummyPrivKey ->
   Tx ->
   [PubKey] ->
-  Eff effs ()
-signTx pabConf tx pubKeys =
-  callCommand @w $
-    ShellArgs
-      "cardano-cli"
-      ( mconcat
-          [ ["transaction", "sign"]
-          , ["--tx-body-file", txFilePath pabConf "raw" tx]
-          , signingKeyFiles
-          , ["--out-file", txFilePath pabConf "signed" tx]
-          ]
-      )
-      (const ())
+  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
   where
     signingKeyFiles =
       concatMap
         (\pubKey -> ["--signing-key-file", signingKeyFilePath pabConf (Ledger.pubKeyHash pubKey)])
         pubKeys
 
+    opts =
+      mconcat
+        [ ["transaction", "sign"]
+        , ["--tx-body-file", txFilePath pabConf "raw" tx]
+        , signingKeyFiles
+        , ["--out-file", txFilePath pabConf "signed" tx]
+        ]
+
 -- Signs and writes a tx (uses the tx body written to disk as input)
 submitTx ::
   forall (w :: Type) (effs :: [Type -> Type]).

src/BotPlutusInterface/Contract.hs

@@ -23,6 +23,7 @@ import Control.Monad.Freer.Extras.Log (handleLogIgnore)
 import Control.Monad.Freer.Extras.Modify (raiseEnd)
 import Control.Monad.Freer.Writer (Writer (Tell))
 import Data.Aeson (ToJSON, Value)
+import Data.Either (isRight)
 import Data.Kind (Type)
 import Data.Map qualified as Map
 import Data.Row (Row)
@@ -193,14 +194,15 @@ writeBalancedTx contractEnv (Right tx) = do
     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
 
       CardanoCLI.uploadFiles @w contractEnv.cePABConfig
 
-      CardanoCLI.buildTx @w contractEnv.cePABConfig ownPkh CardanoCLI.BuildAuto tx
-      CardanoCLI.signTx @w contractEnv.cePABConfig tx requiredSigners
+      CardanoCLI.buildTx @w contractEnv.cePABConfig privKeys ownPkh CardanoCLI.BuildAuto tx
+      res <- CardanoCLI.signTx @w contractEnv.cePABConfig privKeys tx requiredSigners
 
       result <-
-        if contractEnv.cePABConfig.pcDryRun
+        if contractEnv.cePABConfig.pcDryRun || isRight res
           then pure Nothing
           else CardanoCLI.submitTx @w contractEnv.cePABConfig tx
 

src/BotPlutusInterface/Files.hs

@@ -2,18 +2,21 @@
 
 module BotPlutusInterface.Files (
   policyScriptFilePath,
+  DummyPrivKey (FromSKey, FromVKey),
+  unDummyPrivateKey,
   validatorScriptFilePath,
   readPrivateKeys,
   signingKeyFilePath,
   txFilePath,
-  readPrivateKey,
   writeAll,
   writePolicyScriptFile,
   redeemerJsonFilePath,
+  mkDummyPrivateKey,
   writeRedeemerJsonFile,
   writeValidatorScriptFile,
   datumJsonFilePath,
-  fromCardanoPaymentKey,
+  skeyToDummyPrivKey,
+  vkeyToDummyPrivKey,
   writeDatumJsonFile,
 ) where
 
@@ -27,8 +30,9 @@ import BotPlutusInterface.Effects (
  )
 import BotPlutusInterface.Types (PABConfig)
 import Cardano.Api (
-  AsType (AsPaymentKey, AsSigningKey),
+  AsType (AsPaymentKey, AsSigningKey, AsVerificationKey),
   FileError,
+  Key (VerificationKey),
   PaymentKey,
   SigningKey,
   getVerificationKey,
@@ -51,14 +55,15 @@ import Data.ByteString.Lazy qualified as LazyByteString
 import Data.ByteString.Short qualified as ShortByteString
 import Data.Either.Combinators (mapLeft)
 import Data.Kind (Type)
+import Data.List (sortOn)
 import Data.Map (Map)
 import Data.Map qualified as Map
-import Data.Maybe (mapMaybe)
+import Data.Maybe (catMaybes, mapMaybe)
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Ledger qualified
-import Ledger.Crypto (PrivateKey, PubKeyHash (PubKeyHash))
+import Ledger.Crypto (PrivateKey, PubKey (PubKey), PubKeyHash (PubKeyHash))
 import Ledger.Tx (Tx)
 import Ledger.Tx qualified as Tx
 import Ledger.TxId qualified as TxId
@@ -67,16 +72,18 @@ import Plutus.V1.Ledger.Api (
   CurrencySymbol,
   Datum (getDatum),
   DatumHash (..),
+  LedgerBytes (LedgerBytes),
   MintingPolicy,
   Redeemer (getRedeemer),
   RedeemerHash (..),
   Script,
   Validator,
   ValidatorHash (..),
+  toBuiltin,
  )
 import PlutusTx (ToData, toData)
 import PlutusTx.Builtins (fromBuiltin)
-import System.FilePath (isExtensionOf)
+import System.FilePath (takeExtension, (</>))
 import Prelude
 
 -- | Filename of a minting policy script
@@ -167,50 +174,92 @@ readPrivateKeys ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   PABConfig ->
-  Eff effs (Either Text (Map PubKeyHash PrivateKey))
+  Eff effs (Either Text (Map PubKeyHash DummyPrivKey))
 readPrivateKeys pabConf = do
   files <- listDirectory @w $ Text.unpack pabConf.pcSigningKeyFileDir
-  let sKeyFiles =
-        map (\filename -> Text.unpack pabConf.pcSigningKeyFileDir ++ "/" ++ filename) $
-          filter ("skey" `isExtensionOf`) files
-  privKeys <- mapM (readPrivateKey @w) sKeyFiles
+
+  privKeys <-
+    catMaybes
+      <$> mapM
+        ( \filename ->
+            let fullPath = Text.unpack pabConf.pcSigningKeyFileDir </> filename
+             in case takeExtension filename of
+                  ".vkey" -> Just <$> readVerificationKey @w fullPath
+                  ".skey" -> Just <$> readSigningKey @w fullPath
+                  _ -> pure Nothing
+        )
+        files
+
   pure $ toPrivKeyMap <$> sequence privKeys
   where
-    toPrivKeyMap :: [PrivateKey] -> Map PubKeyHash PrivateKey
+    toPrivKeyMap :: [DummyPrivKey] -> Map PubKeyHash DummyPrivKey
     toPrivKeyMap =
       foldl
         ( \pKeyMap pKey ->
-            let pkh = Ledger.pubKeyHash $ Ledger.toPublicKey pKey
+            let pkh = Ledger.pubKeyHash $ Ledger.toPublicKey $ unDummyPrivateKey pKey
              in Map.insert pkh pKey pKeyMap
         )
         Map.empty
+        . sortOn keyPriority
+
+    keyPriority :: DummyPrivKey -> Int
+    keyPriority (FromSKey _) = 1
+    keyPriority (FromVKey _) = 0
 
-readPrivateKey ::
+data DummyPrivKey
+  = FromSKey PrivateKey
+  | FromVKey PrivateKey
+
+unDummyPrivateKey :: DummyPrivKey -> PrivateKey
+unDummyPrivateKey (FromSKey key) = key
+unDummyPrivateKey (FromVKey key) = key
+
+readSigningKey ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   FilePath ->
-  Eff effs (Either Text PrivateKey)
-readPrivateKey filePath = do
+  Eff effs (Either Text DummyPrivKey)
+readSigningKey filePath = do
   pKey <- mapLeft (Text.pack . show) <$> readFileTextEnvelope @w (AsSigningKey AsPaymentKey) filePath
-  pure $ fromCardanoPaymentKey =<< pKey
+  pure $ skeyToDummyPrivKey =<< pKey
+
+readVerificationKey ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  FilePath ->
+  Eff effs (Either Text DummyPrivKey)
+readVerificationKey filePath = do
+  pKey <- mapLeft (Text.pack . show) <$> readFileTextEnvelope @w (AsVerificationKey AsPaymentKey) filePath
+  pure $ vkeyToDummyPrivKey =<< pKey
+
+vkeyToDummyPrivKey :: VerificationKey PaymentKey -> Either Text DummyPrivKey
+vkeyToDummyPrivKey =
+  fmap FromVKey . vkeyToDummyPrivKey'
+
+skeyToDummyPrivKey :: SigningKey PaymentKey -> Either Text DummyPrivKey
+skeyToDummyPrivKey =
+  fmap FromSKey . vkeyToDummyPrivKey' . getVerificationKey
 
 {- | Warning! This implementation is not correct!
  This private key is derived from a normal signing key which uses a 32 byte private key compared
  to the extended key which is 64 bytes. Also, the extended key includes a chain index value
 
- This keys sole purpose is to be able to derive a public key from it, which is then used for
+ This key's sole purpose is to be able to derive a public key from it, which is then used for
  mapping to a signing key file for the CLI
 -}
-fromCardanoPaymentKey :: SigningKey PaymentKey -> Either Text PrivateKey
-fromCardanoPaymentKey sKey =
-  let dummyPrivKeySuffix = ByteString.replicate 32 0
+vkeyToDummyPrivKey' :: VerificationKey PaymentKey -> Either Text PrivateKey
+vkeyToDummyPrivKey' =
+  mkDummyPrivateKey . PubKey . LedgerBytes . toBuiltin . serialiseToRawBytes
+
+mkDummyPrivateKey :: PubKey -> Either Text PrivateKey
+mkDummyPrivateKey (PubKey (LedgerBytes pubkey)) =
+  let dummyPrivKey = ByteString.replicate 32 0
+      dummyPrivKeySuffix = ByteString.replicate 32 0
       dummyChainCode = ByteString.replicate 32 1
-      vKey = getVerificationKey sKey
-      privkeyBS = serialiseToRawBytes sKey
-      pubkeyBS = serialiseToRawBytes vKey
+      pubkeyBS = fromBuiltin pubkey
    in mapLeft Text.pack $
         Crypto.xprv $
-          mconcat [privkeyBS, dummyPrivKeySuffix, pubkeyBS, dummyChainCode]
+          mconcat [dummyPrivKey, dummyPrivKeySuffix, pubkeyBS, dummyChainCode]
 
 serialiseScript :: Script -> PlutusScript PlutusScriptV1
 serialiseScript =

src/BotPlutusInterface/PreBalance.hs

@@ -7,6 +7,7 @@ module BotPlutusInterface.PreBalance (
 
 import BotPlutusInterface.CardanoCLI qualified as CardanoCLI
 import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissing, printLog)
+import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey)
 import BotPlutusInterface.Files qualified as Files
 import BotPlutusInterface.Types (LogLevel (Debug), PABConfig)
 import Cardano.Api.Shelley (Lovelace (Lovelace), ProtocolParameters (protocolParamUTxOCostPerWord))
@@ -28,7 +29,7 @@ import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Address (Address (..))
 import Ledger.Constraints.OffChain (UnbalancedTx (..), fromScriptOutput)
-import Ledger.Crypto (PrivateKey, PubKeyHash)
+import Ledger.Crypto (PubKeyHash)
 import Ledger.Interval (
   Extended (Finite, NegInf, PosInf),
   Interval (Interval),
@@ -86,7 +87,7 @@ preBalanceTxIO pabConf ownPkh unbalancedTx =
   where
     loop ::
       Map TxOutRef TxOut ->
-      Map PubKeyHash PrivateKey ->
+      Map PubKeyHash DummyPrivKey ->
       [PubKeyHash] ->
       [(TxOut, Integer)] ->
       Tx ->
@@ -105,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 ownPkh (CardanoCLI.BuildRaw 0) txWithoutFees
+      lift $ CardanoCLI.buildTx @w pabConf privKeys ownPkh (CardanoCLI.BuildRaw 0) txWithoutFees
       fees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees
 
       lift $ printLog @w Debug $ "Fees: " ++ show fees
@@ -132,7 +133,7 @@ preBalanceTx ::
   Integer ->
   Map TxOutRef TxOut ->
   PubKeyHash ->
-  Map PubKeyHash PrivateKey ->
+  Map PubKeyHash DummyPrivKey ->
   [PubKeyHash] ->
   Tx ->
   Either Text Tx
@@ -261,12 +262,12 @@ balanceNonAdaOuts ownPkh utxos tx =
 {- | Add the required signatorioes to the transaction. Be aware the the signature itself is invalid,
  and will be ignored. Only the pub key hashes are used, mapped to signing key files on disk.
 -}
-addSignatories :: PubKeyHash -> Map PubKeyHash PrivateKey -> [PubKeyHash] -> Tx -> Either Text Tx
+addSignatories :: PubKeyHash -> Map PubKeyHash DummyPrivKey -> [PubKeyHash] -> Tx -> Either Text Tx
 addSignatories ownPkh privKeys pkhs tx =
   foldM
     ( \tx' pkh ->
         case Map.lookup pkh privKeys of
-          Just privKey -> Right $ Tx.addSignature' privKey tx'
+          Just privKey -> Right $ Tx.addSignature' (unDummyPrivateKey privKey) tx'
           Nothing -> Left "Signing key not found."
     )
     tx