batch signatures

pact-request-api/Pact/Core/Command/Client.hs

@@ -37,16 +37,19 @@ module Pact.Core.Command.Client (
   SubmitBatch(..),
 ) where
 
+import Control.Applicative
 import Control.Lens
-import Control.Applicative((<|>))
 import Control.Monad.Except
 import Control.Exception.Safe
 import Control.Monad
 import qualified Crypto.Hash.Algorithms as Crypto
 import Data.Default(def)
 import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import qualified Data.ByteString.Short as SBS
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
@@ -71,28 +74,22 @@ import System.FilePath
 
 import qualified Pact.JSON.Decode as JD
 import qualified Pact.JSON.Encode as J
-import qualified Data.Set as S
-import qualified Data.Map.Strict as M
-import qualified Data.ByteString.Lazy.Char8 as BSL
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.ByteString.Short as SBS
 
 import Pact.Core.ChainData
+import Pact.Core.Command.Crypto
+import Pact.Core.Gas.Types
+import Pact.Core.Guards
 import Pact.Core.Command.RPC
+import Pact.Core.Command.SigData
 import Pact.Core.Command.Types
 import Pact.Core.Command.Util
-import Pact.Core.Command.Crypto
-import Pact.Core.Gas
-import Pact.Core.Guards
-import Pact.Core.Hash
+import Pact.Core.Hash as PactHash
 import Pact.Core.PactValue
 import Pact.Core.Names
 import Pact.Core.SPV
 import Pact.Core.Signer
 import Pact.Core.StableEncoding
 import Pact.Core.Verifiers
-import qualified Pact.Core.Hash as PactHash
-import Pact.Core.Command.SigData
 
 
 -- -------------------------------------------------------------------------- --
@@ -208,7 +205,7 @@ instance J.Encode ApiPublicMeta where
 
 data ApiReq = ApiReq {
   _ylType :: Maybe Text,
-  _ylPactTxHash :: Maybe Hash,
+  _ylPactTxHash :: Maybe PactHash.Hash,
   _ylStep :: Maybe Int,
   _ylRollback :: Maybe Bool,
   _ylData :: Maybe PactValue,
@@ -405,7 +402,7 @@ returnSigDataOrCommand  outputLocal sd
       Left "Number of signers in the payload does not match number of signers in the sigData"
     usrSigs <- traverse (toSignerPair sigMap) (_pSigners payload)
     traverse_ Left $ verifyUserSigs h [ (signer, sig) | (sig, Just signer) <- usrSigs ]
-    _ <- verifyHash h (T.encodeUtf8 cmd)
+    _ <- PactHash.verifyHash h (T.encodeUtf8 cmd)
     pure ()
     where
     toSignerPair sigMap signer =
@@ -533,7 +530,7 @@ signCmd keyFiles bs = do
     Right h -> do
       kps <- mapM importKeyFile keyFiles
       fmap (encodeYaml . J.Object) $ forM kps $ \kp -> do
-            let sig = signHash (Hash $ SBS.toShort h) kp
+            let sig = signHash (PactHash.Hash $ SBS.toShort h) kp
             return ((toB16Text . _b16JsonBytes) (B16JsonBytes (getPublic kp)), sig)
 
 withKeypairsOrSigner
@@ -689,7 +686,7 @@ mkApiReqCont unsignedReq ar@ApiReq{..} fp = do
                           JD.eitherDecode
       (Nothing,Nothing) -> return PUnit
       _ -> dieAR "Expected either a 'data' or 'dataFile' entry, or neither"
-  let pactId = (DefPactId . hashToText) apiPactId
+  let pactId = (DefPactId . PactHash.hashToText) apiPactId
   pubMeta <- mkPubMeta _ylPublicMeta
   cmd <- withKeypairsOrSigner unsignedReq ar
     (\ks -> mkCont pactId step rollback cdata pubMeta ks (fromMaybe [] _ylVerifiers) _ylNonce _ylProof _ylNetworkId)

pact-tests/Pact/Core/Test/CommandTests.hs

@@ -8,6 +8,7 @@ module Pact.Core.Test.CommandTests
   ) where
 
 import qualified Data.Aeson as A
+import Data.List.Unsafe
 import Data.Foldable (forM_)
 import Data.ByteString
 import Data.Text
@@ -17,7 +18,7 @@ import Test.Tasty.HUnit
 import Pact.Core.PactValue
 
 import Pact.Core.Command.Client
-import Pact.Core.Command.Crypto (generateEd25519KeyPair, generateWebAuthnEd25519KeyPair)
+import Pact.Core.Command.Crypto
 import Pact.Core.Command.RPC
 import Pact.Core.Command.Types
 import Pact.Core.StableEncoding
@@ -48,14 +49,56 @@ tests = do
           metaData = StableEncoding (PUnit)
           mkRpc :: Text -> PactRPC Text
           mkRpc pactCode = Exec $ ExecMsg { _pmCode = pactCode, _pmData = PUnit }
-        cmds <- mkCommandsWithBatchSignatures (webAuthnKeys, [])
+        cmdsA <- mkCommandsWithBatchSignatures (webAuthnKeys, [])
           [([], metaData, "nonce-1", Nothing, mkRpc "(+ 1 1)")
           ,([], metaData, "nonce-2", Nothing, mkRpc "(+ 1 2)")
           ,([], metaData, "nonce-3", Nothing, mkRpc "(+ 1 3)")
           ,([], metaData, "nonce-4", Nothing, mkRpc "(+ 1 4)")
           ]
-        forM_ cmds $ \cmd -> case verifyCommand @(StableEncoding PactValue) cmd of
+
+        -- Happy Path: All commands in the batch should verify.
+        forM_ cmdsA $ \cmd -> case verifyCommand @(StableEncoding PactValue) cmd of
           ProcFail f -> assertFailure $ "Command should be valid: " <> show f
           ProcSucc _ -> pure ()
 
+        cmdsB <- mkCommandsWithBatchSignatures (webAuthnKeys, [])
+          [([], metaData, "nonce-5", Nothing, mkRpc "(+ 1 2)")]
+
+        -- Sanity Check: Swapping an unrelated signature into a command should cause
+        -- verification to fail.
+        let (cmdA', _cmdB') = swapSignatures (unsafeHead cmdsA) (unsafeHead cmdsB)
+        case verifyCommand @(StableEncoding PactValue) cmdA' of
+          ProcSucc _ -> assertFailure $ "Command verification should fail"
+          ProcFail _ -> pure ()
+
+        -- Merkle Test: We will make a valid Merkle Root and Merkle Proof for a
+        -- batch signature, but recombine parts of the Batch Tokens, so that
+        -- the WebAuthn signature of the root is correct for the command, but
+        -- the MerkleProof isn't valid.
+        let (cmdA'', _cmdB'') = swapBatchTokenProofs (unsafeHead cmdsA) (unsafeHead cmdsB)
+        case verifyCommand @(StableEncoding PactValue) cmdA'' of
+          ProcSucc _ -> assertFailure $ "Command verification should fail"
+          ProcFail _ -> pure ()
     ]
+
+swapSignatures :: Command a -> Command b -> (Command a, Command b)
+swapSignatures cmdA cmdB =
+  (cmdA { _cmdSigs = _cmdSigs cmdB },
+   cmdB { _cmdSigs = _cmdSigs cmdA }
+  )
+
+swapBatchTokenProofs :: Command a -> Command b -> (Command a, Command b)
+swapBatchTokenProofs cmdA cmdB =
+  case (_cmdSigs cmdA, _cmdSigs cmdB) of
+    ([WebAuthnBatchToken tokenA], [WebAuthnBatchToken tokenB]) ->
+      let (sigA', sigB') = swapProofs tokenA tokenB
+      in (cmdA { _cmdSigs = [WebAuthnBatchToken sigA'] },
+          cmdB { _cmdSigs = [WebAuthnBatchToken sigB'] }
+         )
+    _ -> error "swapBatchTokenProofs is only meant to be called for commands with a single WebAuthnBatchToken signature"
+  where
+    swapProofs :: BatchToken  -> BatchToken -> (BatchToken, BatchToken)
+    swapProofs tokenA tokenB =
+      (tokenA { _btMerkleProofObject = _btMerkleProofObject tokenB },
+       tokenB { _btMerkleProofObject = _btMerkleProofObject tokenA }
+      )

pact-tng.cabal

@@ -1,4 +1,4 @@
-cabal-version:       3.8
+cabal-version:       3.12
 name:                pact-tng
 version:             5.0
 -- ^ 4 digit is prerelease, 3- or 2-digit for prod release
@@ -379,11 +379,7 @@ executable pact
   default-language:    Haskell2010
 
   -- beware of the autogen modules. Remember to `cabal clean`!
-  other-modules:
-    -- TODO: Uncomment once this is finally fixed
-    -- and stops crapping out both LSP and our CI,
-    -- PackageInfo_pact_tng
-    Paths_pact_tng
+  other-modules: PackageInfo_pact_tng
 
 benchmark bench
   type: exitcode-stdio-1.0

pact/Pact/Core/StableEncoding.hs

@@ -687,3 +687,6 @@ instance JD.FromJSON (StableEncoding RowDataValue) where
           <$> (fmap _stableEncoding $ o JD..: "refName")
           <*> (maybe mempty (S.fromList . fmap _stableEncoding) <$> o JD..: "refSpec")
   {-# INLINE parseJSON #-}
+
+-- instance J.Encode (StableEncoding a) => J.Encode (StableEncoding [a]) where
+--   build (StableEncoding a) = J.build (J.Array (fmap StableEncoding a))