Correct mempool tx persistence, check tx details in validate (#1348)

Co-authored-by: Stuart Popejoy <slpopejoy@users.noreply.github.com>

Author: sirlensalot

.github/workflows/applications.yml

@@ -572,7 +572,7 @@ jobs:
       with:
         registry: ghcr.io
         username: kadena-build
-        password: ${{ secrets.PKG_MANAGEMENT }}
+        password: ${{ secrets.GITHUB_TOKEN }}
 
     - name: Build and push
       id: docker_build

bench/Chainweb/Pact/Backend/ForkingBench.hs

@@ -474,7 +474,7 @@ safeCapitalize = maybe [] (uncurry (:) . bimap toUpper (Prelude.map toLower)) .
 
 validateCommand :: Command Text -> Either String ChainwebTransaction
 validateCommand cmdText = case verifyCommand cmdBS of
-    ProcSucc cmd -> Right (mkPayloadWithText <$> cmd)
+    ProcSucc cmd -> Right (mkPayloadWithTextOld <$> cmd)
     ProcFail err -> Left err
   where
     cmdBS :: Command ByteString

chainweb.cabal

@@ -1,7 +1,7 @@
 cabal-version: 2.4
 
 name:         chainweb
-version:      2.12
+version:      2.12.1
 synopsis:     A Proof-of-Work Parallel-Chain Architecture for Massive Throughput
 description:  A Proof-of-Work Parallel-Chain Architecture for Massive Throughput.
 homepage:     https://github.com/kadena-io/chainweb
@@ -770,4 +770,3 @@ benchmark bench
         , streaming-commons >= 0.2
         , unordered-containers == 0.2.15.0
         , yet-another-logger >= 0.4
-

src/Chainweb/Mempool/Mempool.hs

@@ -223,6 +223,8 @@ data InsertError = InsertErrorDuplicate
                  | InsertErrorBuyGas Text
                  | InsertErrorCompilationFailed Text
                  | InsertErrorOther Text
+                 | InsertErrorInvalidHash
+                 | InsertErrorInvalidSigs
   deriving (Generic, Eq, NFData)
 
 instance Show InsertError
@@ -240,6 +242,8 @@ instance Show InsertError
     show (InsertErrorBuyGas msg) = "Attempt to buy gas failed with: " <> T.unpack msg
     show (InsertErrorCompilationFailed msg) = "Transaction compilation failed: " <> T.unpack msg
     show (InsertErrorOther m) = "insert error: " <> T.unpack m
+    show InsertErrorInvalidHash = "Invalid transaction hash"
+    show InsertErrorInvalidSigs = "Invalid transaction sigs"
 
 instance Exception InsertError
 

src/Chainweb/Pact/PactService/ExecBlock.hs

@@ -196,7 +196,9 @@ validateChainwebTxs v cid cp txValidationTime bh txs doBuyGas
   where
     go = V.mapM validations initTxList >>= doBuyGas
 
-    validations t = runValid checkUnique t
+    validations t =
+      runValid checkUnique t
+      >>= runValid checkTx
       >>= runValid checkTimes
       >>= runValid (return . checkCompile)
 
@@ -213,6 +215,31 @@ validateChainwebTxs v cid cp txValidationTime bh txs doBuyGas
         | timingsCheck txValidationTime $ fmap payloadObj t = return $ Right t
         | otherwise = return $ Left InsertErrorInvalidTime
 
+    checkTx :: ChainwebTransaction -> IO (Either InsertError ChainwebTransaction)
+    checkTx t
+        | doCheckTx v bh =
+            case P.verifyHash (P._cmdHash t) (SB.fromShort $ payloadBytes $ P._cmdPayload t) of
+              Left _ -> pure $ Left InsertErrorInvalidHash
+              Right _ -> case validateSigs t of
+                Left _ -> pure $ Left InsertErrorInvalidSigs
+                Right _ -> pure $ Right t
+        | otherwise = pure $ Right t
+
+    validateSigs :: ChainwebTransaction -> Either () ()
+    validateSigs t
+        | length signers /= length sigs = Left ()
+        | otherwise = case traverse validateSig $ zip signers sigs of
+            Left _ -> Left ()
+            Right _ -> Right ()
+      where
+        hsh = P._cmdHash t
+        sigs = P._cmdSigs t
+        signers = P._pSigners $ payloadObj $ P._cmdPayload t
+        validateSig (signer,sig)
+            | P.verifyUserSig hsh sig signer = Right ()
+            | otherwise = Left ()
+
+
     initTxList :: ValidateTxs
     initTxList = V.map Right txs
 

src/Chainweb/Pact/RestAPI/Server.hs

@@ -107,7 +107,7 @@ import Chainweb.SPV.CreateProof
 import Chainweb.SPV.EventProof
 import Chainweb.SPV.OutputProof
 import Chainweb.SPV.PayloadProof
-import Chainweb.Transaction (ChainwebTransaction, mkPayloadWithText)
+import Chainweb.Transaction
 import qualified Chainweb.TreeDB as TreeDB
 import Chainweb.Utils
 import Chainweb.Version
@@ -620,12 +620,13 @@ toPactTx (Transaction b) = decodeStrict' b
 
 validateCommand :: Command Text -> Either String ChainwebTransaction
 validateCommand cmdText = case verifyCommand cmdBS of
-    ProcSucc cmd -> Right (mkPayloadWithText <$> cmd)
+    ProcSucc cmd -> Right (mkPayloadWithText cmdBS <$> cmd)
     ProcFail err -> Left err
   where
     cmdBS :: Command ByteString
     cmdBS = encodeUtf8 <$> cmdText
 
+
 -- | Validate the length of the request key's underlying hash.
 --
 validateRequestKey :: RequestKey -> Handler ()

src/Chainweb/Transaction.hs

@@ -18,6 +18,7 @@ module Chainweb.Transaction
   , timeToLiveOf
   , creationTimeOf
   , mkPayloadWithText
+  , mkPayloadWithTextOld
   , payloadBytes
   , payloadObj
   ) where
@@ -62,10 +63,15 @@ payloadObj :: PayloadWithText -> Payload PublicMeta ParsedCode
 payloadObj = _payloadObj
 
 
-mkPayloadWithText :: Payload PublicMeta ParsedCode -> PayloadWithText
-mkPayloadWithText p = PayloadWithText {
-    _payloadBytes =
-    SB.toShort $ BL.toStrict $ Aeson.encode $ fmap _pcCode p
+mkPayloadWithText :: Command ByteString -> Payload PublicMeta ParsedCode -> PayloadWithText
+mkPayloadWithText cmd p = PayloadWithText
+    { _payloadBytes = SB.toShort $ _cmdPayload cmd
+    , _payloadObj = p
+    }
+
+mkPayloadWithTextOld :: Payload PublicMeta ParsedCode -> PayloadWithText
+mkPayloadWithTextOld p = PayloadWithText
+    { _payloadBytes = SB.toShort $ BL.toStrict $ Aeson.encode $ fmap _pcCode p
     , _payloadObj = p
     }
 

src/Chainweb/Version.hs

@@ -60,6 +60,7 @@ module Chainweb.Version
 , pact420Upgrade
 , enforceKeysetFormats
 , AtOrAfter(..)
+, doCheckTx
 
 -- ** BlockHeader Validation Guards
 , slowEpochGuard
@@ -905,6 +906,13 @@ enforceKeysetFormats Testnet04 = (>= 1_701_000) -- 2021-11-18T17:54:36
 enforceKeysetFormats Development = (>= 100)
 enforceKeysetFormats _ = (>= 10)
 
+doCheckTx :: ChainwebVersion -> BlockHeight -> Bool
+doCheckTx Mainnet01 = (>= 2_349_800) -- 2022-01-23T02:53:38
+doCheckTx Testnet04 = (>= 1_889_000) -- 2022-01-24T04:19:24
+doCheckTx Development = (>= 110)
+doCheckTx (FastTimedCPM g) | g == petersonChainGraph = (>= 7)
+doCheckTx _ = const False
+
 -- -------------------------------------------------------------------------- --
 -- Header Validation Guards
 --

test/Chainweb/Test/Pact/PactInProcApi.hs

@@ -47,8 +47,6 @@ import Test.Tasty.HUnit
 
 -- internal modules
 
-import Pact.Parse
-import Pact.Types.ChainMeta
 import Pact.Types.Continuation
 import Pact.Types.Exp
 import Pact.Types.Command
@@ -76,7 +74,6 @@ import Chainweb.Test.Cut.TestBlockDb
 import Chainweb.Test.Pact.Utils
 import Chainweb.Test.Utils
 import Chainweb.Time
-import Chainweb.Transaction
 import Chainweb.Utils
 import Chainweb.Version
 import Chainweb.Version.Utils
@@ -748,7 +745,7 @@ goldenMemPool = mempty
     { mpaGetBlock = getTestBlock
     }
   where
-    getTestBlock validate bHeight bHash parent = do
+    getTestBlock validate bHeight bHash _parent = do
         moduleStr <- readFile' $ testPactFilesDir ++ "test1.pact"
         let txs =
               [ (T.pack moduleStr)
@@ -763,16 +760,7 @@ goldenMemPool = mempty
               , "(at 'chain-id (chain-data))"
               , "(at 'sender (chain-data))"
               ]
-        outtxs' <- mkTxs txs
-        -- the following is done post-hash which is lame but in
-        -- the goldens. TODO boldly overwrite goldens at some point of
-        -- great stability
-        let f = modifyPayloadWithText . set (pMeta . pmCreationTime)
-            g = modifyPayloadWithText . set (pMeta . pmTTL)
-            t = toTxCreationTime $ _bct $ _blockCreationTime parent
-        let outtxs = flip V.map outtxs' $ \tx ->
-                let ttl = TTLSeconds $ ParsedInteger $ 24 * 60 * 60
-                in fmap (g ttl . f t) tx
+        outtxs <- mkTxs txs
         oks <- validate bHeight bHash outtxs
         unless (V.and oks) $ fail $ mconcat
             [ "tx failed validation! input list: \n"
@@ -791,7 +779,3 @@ goldenMemPool = mempty
           mkCmd ("1" <> sshow n) $
           mkExec code $
           mkKeySetData "test-admin-keyset" [sender00]
-    modifyPayloadWithText f pwt = mkPayloadWithText newPayload
-      where
-        oldPayload = payloadObj pwt
-        newPayload = f oldPayload

test/Chainweb/Test/Pact/Utils.hs

@@ -8,6 +8,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
 
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 -- |
@@ -378,9 +380,11 @@ mkCmd nonce rpc = defaultCmd
 --
 buildCwCmd :: CmdBuilder -> IO ChainwebTransaction
 buildCwCmd cmd = buildRawCmd cmd >>= \c -> case verifyCommand c of
-    ProcSucc r -> return $ fmap mkPayloadWithText r
+    ProcSucc r -> return $ fmap (mkPayloadWithText c) r
     ProcFail e -> throwM $ userError $ "buildCmd failed: " ++ e
 
+
+
 -- | Build unparsed, unverified command
 --
 buildTextCmd :: CmdBuilder -> IO (Command Text)