add a mempool insertCheck variant that doesn't short-circuit. improve…

… error messages in /send api

Change-Id: I435856410fb82c59f8170d32bf12e5cea69833d1

src/Chainweb/Mempool/InMem.hs

@@ -3,10 +3,12 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -25,6 +27,8 @@ module Chainweb.Mempool.InMem
   ) where
 
 ------------------------------------------------------------------------------
+
+import Data.List qualified as List
 import Control.Applicative ((<|>))
 import Control.Concurrent.Async
 import Control.Concurrent.MVar
@@ -119,45 +123,26 @@ toMempoolBackend
 toMempoolBackend logger mempool = do
     return $! MempoolBackend
       { mempoolTxConfig = tcfg
-      , mempoolMember = member
-      , mempoolLookup = lookup
-      , mempoolLookupEncoded = lookupEncoded
-      , mempoolInsert = insert
-      , mempoolInsertCheck = insertCheck
-      , mempoolMarkValidated = markValidated
-      , mempoolAddToBadList = addToBadList
-      , mempoolCheckBadList = checkBadList
-      , mempoolGetBlock = getBlock
-      , mempoolPrune = prune
-      , mempoolGetPendingTransactions = getPending
-      , mempoolClear = clear
+      , mempoolMember = memberInMem lockMVar
+      , mempoolLookup = lookupInMem tcfg lockMVar
+      , mempoolLookupEncoded = lookupEncodedInMem lockMVar
+      , mempoolInsert = insertInMem logger cfg lockMVar
+      , mempoolInsertCheck = insertCheckInMem cfg lockMVar
+      , mempoolInsertCheckVerbose = insertCheckVerboseInMem cfg lockMVar
+      , mempoolMarkValidated = markValidatedInMem logger tcfg lockMVar
+      , mempoolAddToBadList = addToBadListInMem lockMVar
+      , mempoolCheckBadList = checkBadListInMem lockMVar
+      , mempoolGetBlock = getBlockInMem logger cfg lockMVar
+      , mempoolPrune = pruneInMem logger lockMVar
+      , mempoolGetPendingTransactions = getPendingInMem cfg nonce lockMVar
+      , mempoolClear = clearInMem lockMVar
       }
   where
     cfg = _inmemCfg mempool
     nonce = _inmemNonce mempool
     lockMVar = _inmemDataLock mempool
 
     InMemConfig tcfg _ _ _ _ _ _ = cfg
-    member = memberInMem lockMVar
-    lookup = lookupInMem tcfg lockMVar
-    lookupEncoded = lookupEncodedInMem lockMVar
-    insert = insertInMem logger cfg lockMVar
-    insertCheck = insertCheckInMem cfg lockMVar
-    markValidated = markValidatedInMem logger tcfg lockMVar
-    addToBadList = addToBadListInMem lockMVar
-    checkBadList = checkBadListInMem lockMVar
-    getBlock :: forall to.
-      (NFData t)
-      => BlockFill
-      -> MempoolPreBlockCheck t to
-      -> BlockHeight
-      -> BlockHash
-      -> IO (Vector to)
-    getBlock = getBlockInMem logger cfg lockMVar
-    getPending = getPendingInMem cfg nonce lockMVar
-    prune = pruneInMem logger lockMVar
-    clear = clearInMem lockMVar
-
 
 ------------------------------------------------------------------------------
 -- | A 'bracket' function for in-memory mempools.
@@ -348,6 +333,66 @@ insertCheckInMem cfg lock txs
     hasher :: t -> TransactionHash
     hasher = txHasher (_inmemTxCfg cfg)
 
+-- | This function is used when a transaction(s) is inserted into the mempool via
+--   the service API. It is NOT used when a new block is created.
+--   For the latter, more strict validation methods are used. In particular, TTL validation
+--   uses the current time as reference in the former case (mempool insertion)
+--   and the creation time of the parent header in the latter case (new block creation).
+--
+insertCheckVerboseInMem
+    :: forall t
+    .  NFData t
+    => InMemConfig t    -- ^ in-memory config
+    -> MVar (InMemoryMempoolData t)  -- ^ in-memory state
+    -> Vector t  -- ^ new transactions
+    -> IO (Vector (T2 TransactionHash (Either InsertError t)))
+insertCheckVerboseInMem cfg lock txs
+  | V.null txs = return V.empty
+  | otherwise = do
+      now <- getCurrentTimeIntegral
+      badmap <- withMVarMasked lock $ readIORef . _inmemBadMap
+      curTxIdx <- withMVarMasked lock $ readIORef . _inmemCurrentTxs
+
+      let withHashesAndPositions :: (HashMap TransactionHash (Int, InsertError), HashMap TransactionHash (Int, t))
+          withHashesAndPositions =
+            over _1 (HashMap.fromList . V.toList)
+            $ over _2 (HashMap.fromList . V.toList)
+            $ V.partitionWith (\(i, h, e) -> bimap (\err -> (h, (i, err))) (\err -> (h, (i, err))) e)
+            $ flip V.imap txs $ \i tx ->
+                let !h = hasher tx
+                in (i, h,) $! validateOne cfg badmap curTxIdx now tx h
+
+      let (prevFailures, prevSuccesses) = withHashesAndPositions
+
+      preInsertBatchChecks <- _inmemPreInsertBatchChecks cfg (V.fromList $ List.map (\(h, (_, t)) -> T2 h t) $ HashMap.toList prevSuccesses)
+
+      let update (failures, successes) result = case result of
+              Left (T2 txHash insertError) ->
+                case HashMap.lookup txHash successes of
+                  Just (i, _) ->
+                    -- add to failures and remove from successes
+                    ( HashMap.insert txHash (i, insertError) failures
+                    , HashMap.delete txHash successes
+                    )
+                  Nothing -> error "insertCheckInMem: impossible"
+              -- nothing to do; the successes already contains this value.
+              Right _ -> (failures, successes)
+      let (failures, successes) = V.foldl' update (prevFailures, prevSuccesses) preInsertBatchChecks
+
+      let allEntries =
+            [ (i, T2 txHash (Left insertError))
+            | (txHash, (i, insertError)) <- HashMap.toList failures
+            ] ++
+            [ (i, T2 txHash (Right val))
+            | (txHash, (i, val)) <- HashMap.toList successes
+            ]
+      let sortedEntries = V.fromList $ List.map snd $ List.sortBy (compare `on` fst) allEntries
+
+      return sortedEntries
+  where
+    hasher :: t -> TransactionHash
+    hasher = txHasher (_inmemTxCfg cfg)
+
 -- | Validation: Confirm the validity of some single transaction @t@.
 --
 -- This function is only used during insert checks. TTL validation is done in

src/Chainweb/Mempool/Mempool.hs

@@ -90,6 +90,7 @@ module Chainweb.Mempool.Mempool
   , pact5RequestKeyToTransactionHash
   ) where
 ------------------------------------------------------------------------------
+
 import Control.DeepSeq (NFData)
 import Control.Exception
 import Control.Lens hiding ((.=))
@@ -237,7 +238,7 @@ data InsertError
   | InsertErrorCompilationFailed Text
   | InsertErrorOther Text
   | InsertErrorInvalidHash
-  | InsertErrorInvalidSigs
+  | InsertErrorInvalidSigs Text
   | InsertErrorTimedOut
   | InsertErrorPactParseError Text
   | InsertErrorWrongChain Text Text
@@ -257,7 +258,7 @@ instance Show InsertError where
       InsertErrorCompilationFailed msg -> "Transaction compilation failed: " <> T.unpack msg
       InsertErrorOther m -> "insert error: " <> T.unpack m
       InsertErrorInvalidHash -> "Invalid transaction hash"
-      InsertErrorInvalidSigs -> "Invalid transaction sigs"
+      InsertErrorInvalidSigs msg -> "Invalid transaction sigs: " <> T.unpack msg
       InsertErrorTimedOut -> "Transaction validation timed out"
       InsertErrorPactParseError msg -> "Pact parse error: " <> T.unpack msg
       InsertErrorWrongChain expected actual -> "Wrong chain, expected: " <> T.unpack expected <> ", actual: " <> T.unpack actual
@@ -295,9 +296,12 @@ data MempoolBackend t = MempoolBackend {
                   -> IO ()
 
     -- | Perform the pre-insert check for the given transactions. Short-circuits
-    -- on the first Transaction that fails.
+    --   on the first Transaction that fails.
   , mempoolInsertCheck :: Vector t -> IO (Either (T2 TransactionHash InsertError) ())
 
+    -- | Perform the pre-insert check for the given transactions. Does not short circuit.
+  , mempoolInsertCheckVerbose :: Vector t -> IO (Vector (T2 TransactionHash (Either InsertError t)))
+
     -- | Remove the given hashes from the pending set.
   , mempoolMarkValidated :: Vector t -> IO ()
 
@@ -342,6 +346,7 @@ noopMempool = do
     , mempoolLookupEncoded = noopLookupEncoded
     , mempoolInsert = noopInsert
     , mempoolInsertCheck = noopInsertCheck
+    , mempoolInsertCheckVerbose = noopInsertCheckVerbose
     , mempoolMarkValidated = noopMV
     , mempoolAddToBadList = noopAddToBadList
     , mempoolCheckBadList = noopCheckBadList
@@ -364,6 +369,7 @@ noopMempool = do
     noopLookupEncoded v = return $ V.replicate (V.length v) Missing
     noopInsert = const $ const $ return ()
     noopInsertCheck _ = fail "unsupported"
+    noopInsertCheckVerbose _ = fail "unsupported"
     noopMV = const $ return ()
     noopAddToBadList = const $ return ()
     noopCheckBadList v = return $ V.replicate (V.length v) False

src/Chainweb/Mempool/RestAPI/Client.hs

@@ -59,6 +59,7 @@ toMempool version chain txcfg env =
     , mempoolLookupEncoded = const unsupported
     , mempoolInsert = insert
     , mempoolInsertCheck = const unsupported
+    , mempoolInsertCheckVerbose = const unsupported
     , mempoolMarkValidated = const unsupported
     , mempoolAddToBadList = const unsupported
     , mempoolCheckBadList = const unsupported

src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs

@@ -327,8 +327,11 @@ checkTxSigs
   -> f ()
 checkTxSigs logger v cid bh t = do
   liftIO $ logFunctionText logger Debug $ "Pact4.checkTxSigs: " <> sshow (Pact4._cmdHash t)
-  if | isRight (Pact4.assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs) -> pure ()
-     | otherwise -> throwError InsertErrorInvalidSigs
+  case Pact4.assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs of
+      Right _ -> do
+          pure ()
+      Left err -> do
+        throwError $ InsertErrorInvalidSigs (displayAssertValidateSigsError err)
   where
     hsh = Pact4._cmdHash t
     sigs = Pact4._cmdSigs t

src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs

@@ -52,7 +52,7 @@ import Control.Monad.State.Strict
 import Data.ByteString (ByteString)
 import Data.Coerce
 import Data.Decimal
-import Data.Either (partitionEithers, isRight)
+import Data.Either (partitionEithers)
 import Data.Foldable
 import Data.Maybe
 import Data.Text qualified as T
@@ -77,6 +77,7 @@ import qualified Chainweb.Pact5.Backend.ChainwebPactDb as Pact5
 import qualified Chainweb.Pact4.Transaction as Pact4
 import qualified Chainweb.Pact5.Transaction as Pact5
 import qualified Chainweb.Pact5.Validations as Pact5
+import Pact.Core.Pretty qualified as Pact5
 import qualified Data.ByteString.Short as SB
 import qualified Pact.Core.Hash as Pact5
 import System.LogLevel
@@ -527,8 +528,11 @@ validateParsedChainwebTx _logger v cid db _blockHandle txValidationTime bh isGen
 
     checkTxSigs :: Pact5.Transaction -> ExceptT InsertError IO ()
     checkTxSigs t = do
-      if | isRight (Pact5.assertValidateSigs hsh signers sigs) -> pure ()
-         | otherwise -> throwError InsertErrorInvalidSigs
+      case Pact5.assertValidateSigs hsh signers sigs of
+          Right _ -> do
+              pure ()
+          Left err -> do
+              throwError $ InsertErrorInvalidSigs (displayAssertValidateSigsError err)
       where
         hsh = Pact5._cmdHash t
         sigs = Pact5._cmdSigs t
@@ -558,7 +562,7 @@ validateRawChainwebTx
     -> Pact4.UnparsedTransaction
     -> ExceptT InsertError IO Pact5.Transaction
 validateRawChainwebTx logger v cid db blockHandle parentTime bh isGenesis tx = do
-  tx' <- either (throwError . InsertErrorPactParseError . sshow) return $ Pact5.parsePact4Command tx
+  tx' <- either (throwError . InsertErrorPactParseError . Pact5.renderText) return $ Pact5.parsePact4Command tx
   liftIO $ do
     logDebug_ logger $ "validateRawChainwebTx: parse succeeded"
   validateParsedChainwebTx logger v cid db blockHandle parentTime bh isGenesis tx'

src/Chainweb/Pact/RestAPI/Server.hs

@@ -46,6 +46,7 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT, except)
 
 import Data.Aeson as Aeson
 import Data.Bifunctor (second)
+import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.ByteString.Lazy.Char8 as BSL8
 import qualified Data.ByteString.Short as SB
@@ -104,6 +105,7 @@ import Chainweb.Pact.RestAPI.EthSpv
 import Chainweb.Pact.RestAPI.SPV
 import Chainweb.Pact.Types
 import Chainweb.Pact4.SPV qualified as Pact4
+import Pact.Types.ChainMeta qualified as Pact4
 import Chainweb.Payload
 import Chainweb.Payload.PayloadStore
 import Chainweb.RestAPI.Orphans ()
@@ -260,11 +262,13 @@ sendHandler
     -> Handler Pact4.RequestKeys
 sendHandler logger mempool (Pact4.SubmitBatch cmds) = Handler $ do
     liftIO $ logg Info (PactCmdLogSend cmds)
-    case (traverse . traverse) (\t -> (encodeUtf8 t,) <$> eitherDecodeStrictText t) cmds of
+    let cmdPayloads :: Either String (NonEmpty (Pact4.Command (ByteString, Pact4.Payload Pact4.PublicMeta Text)))
+        cmdPayloads = traverse (traverse (\t -> (encodeUtf8 t,) <$> eitherDecodeStrictText t)) cmds
+    case cmdPayloads of
       Right (fmap Pact4.mkPayloadWithText -> cmdsWithParsedPayloads) -> do
           let cmdsWithParsedPayloadsV = V.fromList $ NEL.toList cmdsWithParsedPayloads
           -- If any of the txs in the batch fail validation, we reject them all.
-          liftIO (mempoolInsertCheck mempool cmdsWithParsedPayloadsV) >>= checkResult
+          liftIO (mempoolInsertCheckVerbose mempool cmdsWithParsedPayloadsV) >>= checkResult
           liftIO (mempoolInsert mempool UncheckedInsert cmdsWithParsedPayloadsV)
           return $! Pact4.RequestKeys $ NEL.map Pact4.cmdToRequestKey cmdsWithParsedPayloads
       Left err -> failWith $ "reading JSON for transaction failed: " <> T.pack err
@@ -276,17 +280,19 @@ sendHandler logger mempool (Pact4.SubmitBatch cmds) = Handler $ do
 
     logg = logFunctionJson (setComponent "send-handler" logger)
 
-    toPactHash :: TransactionHash -> Pact4.TypedHash h
-    toPactHash (TransactionHash h) = Pact4.TypedHash h
-
-    checkResult :: Either (T2 TransactionHash InsertError) () -> ExceptT ServerError IO ()
-    checkResult (Right _) = pure ()
-    checkResult (Left (T2 hash insErr)) = failWith $ fold
-        [ "Validation failed for hash "
-        , sshow $ toPactHash hash
-        , ": "
-        , sshow insErr
-        ]
+    checkResult :: Vector (T2 TransactionHash (Either InsertError Pact4.UnparsedTransaction)) -> ExceptT ServerError IO ()
+    checkResult vec
+        | V.null vec = return ()
+        | otherwise = do
+            let errors = flip mapMaybe (L.zip [0..] (V.toList vec)) $ \(i, T2 txHash e) -> case e of
+                    Left err -> Just $ "Transaction " <> sshow txHash <> " at index " <> sshow @Word i <> " failed with: " <> sshow err
+                    Right _ -> Nothing
+            if null errors
+            then do
+                return ()
+            else do
+                let err = "One or more transactions were invalid: " <> T.intercalate ", " errors
+                failWith err
 
 -- -------------------------------------------------------------------------- --
 -- Poll Handler