Skip to content

Commit

Permalink
Erase Pact version info from LocalResult
Browse files Browse the repository at this point in the history
  • Loading branch information
@edmundnoble
edmundnoble committed Dec 22, 2024
1 parent a2a82ba commit dedf18a
Show file tree
Hide file tree
Showing 7 changed files with 154 additions and 95 deletions.
25 changes: 13 additions & 12 deletions src/Chainweb/Pact/PactService.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -801,8 +801,8 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
, _crEvents = []
}
in case preflight of
Just PreflightSimulation -> return $ LocalResultWithWarns parseError []
_ -> return $ LocalResultLegacy parseError
Just PreflightSimulation -> return $ Pact4LocalResultWithWarns parseError []
_ -> return $ Pact4LocalResultLegacy parseError
Right pact4Cwtx -> do

--
Expand All @@ -823,8 +823,8 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do

let cr' = hashPact4TxLogs cr
warns' = Pact4.renderCompactText <$> toList warns
pure $ LocalResultWithWarns cr' warns'
Left e -> pure $ MetadataValidationFailure e
pure $ Pact4LocalResultWithWarns cr' warns'
Left e -> pure $ review _MetadataValidationFailure e
_ -> liftIO $ do
let execConfig = Pact4.mkExecutionConfig $
[ Pact4.FlagAllowReadInLocal | _psAllowReadsInLocal ] ++
Expand All @@ -838,12 +838,12 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
pact4Cwtx mc execConfig

let cr' = hashPact4TxLogs cr
pure $ LocalResultLegacy cr'
pure $ Pact4LocalResultLegacy cr'
) (do
ph <- view psParentHeader
case Pact5.parsePact4Command cwtx of
Left (fmap Pact5.spanInfoToLineInfo -> parseError) ->
return $ LocalPact5PreflightResult Pact5.CommandResult
return $ Pact5LocalResultLegacy Pact5.CommandResult
{ _crReqKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx)
, _crTxId = Nothing
, _crResult = Pact5.PactResultErr $ Pact5.PELegacyError $ Pact5.toPrettyLegacyError parseError
Expand All @@ -853,14 +853,13 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
, _crMetaData = Nothing
, _crEvents = []
}
[]
Right pact5Cmd -> do
let txCtx = Pact5.TxContext ph noMiner
let spvSupport = Pact5.pactSPV bhdb (_parentHeader ph)
case preflight of
Just PreflightSimulation ->
Pact5.liftPactServiceM (Pact5.assertLocalMetadata (view Pact5.payloadObj <$> pact5Cmd) txCtx sigVerify) >>= \case
Left e -> pure $ MetadataValidationFailure e
Left e -> pure $ review _MetadataValidationFailure e
Right () -> do
let initialGas = Pact5.initialGasOf $ Pact5._cmdPayload pact5Cmd
Pact5.pactTransaction Nothing (\dbEnv ->
Expand All @@ -869,7 +868,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
txCtx spvSupport initialGas (view Pact5.payloadObj <$> pact5Cmd)
) >>= \case
Left err ->
return $ LocalPact5PreflightResult Pact5.CommandResult
return $ Pact5LocalResultWithWarns Pact5.CommandResult
{ _crReqKey = Pact5.RequestKey (Pact5.Hash $ Pact4.unHash $ Pact4.toUntypedHash $ Pact4._cmdHash cwtx)
, _crTxId = Nothing
-- FIXME: Pact5, make this nicer, the `sshow` makes for an ugly error
Expand All @@ -885,11 +884,13 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
Right cr -> do
let cr' = hashPact5TxLogs cr
-- FIXME: Pact5, no warnings yet
pure $ LocalPact5PreflightResult (Pact5.PELegacyError . Pact5.toPrettyLegacyError <$> cr') []
pure $ Pact5LocalResultWithWarns
(Pact5.PELegacyError . Pact5.toPrettyLegacyError <$> cr')
[]
_ -> do
cr <- Pact5.pactTransaction Nothing $ \dbEnv -> do
fmap convertPact5Error <$> Pact5.applyLocal _psLogger _psGasLogger dbEnv txCtx spvSupport (view Pact5.payloadObj <$> pact5Cmd)
pure $ LocalPact5ResultLegacy (hashPact5TxLogs cr)
pure $ Pact5LocalResultLegacy (hashPact5TxLogs cr)

)

Expand All @@ -899,7 +900,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
Just r -> pure r
Nothing -> do
logError_ _psLogger $ "Local action timed out for cwtx:\n" <> sshow cwtx
pure LocalTimeout
pure $ review _LocalTimeout ()

execSyncToBlock
:: (CanReadablePayloadCas tbl, Logger logger)
Expand Down
2 changes: 1 addition & 1 deletion src/Chainweb/Pact/RestAPI/Server.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -390,7 +390,7 @@ localHandler logger pact preflight sigVerify rewindDepth cmd = do
case r of
Left (err :: PactException) -> throwError $ setErrText
("Execution failed: " <> T.pack (show err)) err400
Right (MetadataValidationFailure e) -> do
Right (preview _MetadataValidationFailure -> Just e) -> do
throwError $ setErrText
("Metadata validation failed: " <> decodeUtf8 (BSL.toStrict (Aeson.encode e))) err400
Right lr -> return $! lr
Expand Down
98 changes: 78 additions & 20 deletions src/Chainweb/Pact/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
Expand All @@ -21,6 +22,7 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ViewPatterns #-}
-- |
-- Module: Chainweb.Pact.Types
-- Copyright: Copyright © 2018 Kadena LLC.
Expand Down Expand Up @@ -81,15 +83,21 @@ module Chainweb.Pact.Types
, SubmittedRequestMsg(..)
, ValidateBlockReq(..)
, RewindDepth(..)
, LocalResult(..)
, LocalReq(..)
, ReadOnlyReplayReq(..)
, ConfirmationDepth(..)
, LocalPreflightSimulation(..)
, LocalResult
, _MetadataValidationFailure
, _LocalResultWithWarns
, _LocalResultLegacy
, _LocalTimeout
, pattern Pact4LocalResultLegacy
, _Pact4LocalResultLegacy
, pattern Pact5LocalResultLegacy
, _Pact5LocalResultLegacy
, pattern Pact4LocalResultWithWarns
, pattern Pact5LocalResultWithWarns
, LocalReq(..)
, ReadOnlyReplayReq(..)
, ConfirmationDepth(..)
, LocalPreflightSimulation(..)
, SyncToBlockReq(..)
, RequestMsg(..)
, RewindLimit(..)
Expand Down Expand Up @@ -251,6 +259,9 @@ import qualified Data.Vector as V
import qualified Pact.Core.Hash as Pact5
import Data.Maybe
import Chainweb.BlockCreationTime
import qualified Data.Aeson as Aeson
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL


-- | Gather tx logs for a block, along with last tx for each
Expand Down Expand Up @@ -770,15 +781,66 @@ data LocalPreflightSimulation
deriving stock (Eq, Show, Generic)

-- | The type of local results (used in /local endpoint)
-- Internally contains a JsonText instead of a CommandResult for compatibility across Pact versions,
-- but the constructors are hidden.
-- This can be undone in the 2.28 release.
--
data LocalResult
= MetadataValidationFailure !(NE.NonEmpty Text)
| LocalResultWithWarns !(Pact4.CommandResult Pact4.Hash) ![Text]
| LocalResultLegacy !(Pact4.CommandResult Pact4.Hash)
| LocalPact5ResultLegacy !(Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info)))
| LocalPact5PreflightResult !(Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info))) ![Text]
| LocalResultLegacy !J.JsonText
| LocalResultWithWarns !J.JsonText ![Text]
| LocalTimeout
deriving stock (Show, Generic)
deriving stock (Generic)

pattern ConvertLocalResultLegacy :: (FromJSON a, J.Encode a) => a -> LocalResult
pattern ConvertLocalResultLegacy cr <- LocalResultLegacy (Aeson.decode . TL.encodeUtf8 . TL.fromStrict . J.getJsonText -> Just cr) where
ConvertLocalResultLegacy cr = LocalResultLegacy (J.encodeJsonText cr)

pattern Pact4LocalResultLegacy
:: Pact4.CommandResult Pact4.Hash
-> LocalResult
pattern Pact4LocalResultLegacy cr <- ConvertLocalResultLegacy cr where
Pact4LocalResultLegacy cr = ConvertLocalResultLegacy cr
_Pact4LocalResultLegacy :: Prism' LocalResult (Pact4.CommandResult Pact4.Hash)
_Pact4LocalResultLegacy = prism' Pact4LocalResultLegacy $ \case
Pact4LocalResultLegacy cr -> Just cr
_ -> Nothing

pattern Pact5LocalResultLegacy
:: Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info))
-> LocalResult
pattern Pact5LocalResultLegacy cr <- ConvertLocalResultLegacy cr where
Pact5LocalResultLegacy cr = ConvertLocalResultLegacy cr
_Pact5LocalResultLegacy :: Prism' LocalResult (Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info)))
_Pact5LocalResultLegacy = prism' Pact5LocalResultLegacy $ \case
Pact5LocalResultLegacy cr -> Just cr
_ -> Nothing

pattern ConvertLocalResultWithWarns :: (FromJSON a, J.Encode a) => a -> [Text] -> LocalResult
pattern ConvertLocalResultWithWarns cr warns <- LocalResultWithWarns (Aeson.decode . TL.encodeUtf8 . TL.fromStrict . J.getJsonText -> Just cr) warns where
ConvertLocalResultWithWarns cr warns = LocalResultWithWarns (J.encodeJsonText cr) warns

pattern Pact4LocalResultWithWarns
:: Pact4.CommandResult Pact4.Hash
-> [Text]
-> LocalResult
pattern Pact4LocalResultWithWarns cr warns <- ConvertLocalResultWithWarns cr warns where
Pact4LocalResultWithWarns cr warns = ConvertLocalResultWithWarns cr warns
_Pact4LocalResultWithWarns :: Prism' LocalResult (Pact4.CommandResult Pact4.Hash, [Text])
_Pact4LocalResultWithWarns = prism' (uncurry Pact4LocalResultWithWarns) $ \case
Pact4LocalResultWithWarns cr warns -> Just (cr, warns)
_ -> Nothing

pattern Pact5LocalResultWithWarns
:: Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info))
-> [Text]
-> LocalResult
pattern Pact5LocalResultWithWarns cr warns <- ConvertLocalResultWithWarns cr warns where
Pact5LocalResultWithWarns cr warns = ConvertLocalResultWithWarns cr warns
_Pact5LocalResultWithWarns :: Prism' LocalResult (Pact5.CommandResult Pact5.Hash (Pact5.PactErrorCompat (Pact5.LocatedErrorInfo Pact5.Info)), [Text])
_Pact5LocalResultWithWarns = prism' (uncurry Pact5LocalResultWithWarns) $ \case
Pact5LocalResultWithWarns cr warns -> Just (cr, warns)
_ -> Nothing

makePrisms ''LocalResult

Expand All @@ -787,15 +849,10 @@ instance J.Encode LocalResult where
[ "preflightValidationFailures" J..= J.Array (J.text <$> e)
]
build (LocalResultLegacy cr) = J.build cr
build (LocalPact5ResultLegacy cr) = J.build cr
build (LocalResultWithWarns cr ws) = J.object
[ "preflightResult" J..= cr
, "preflightWarnings" J..= J.Array (J.text <$> ws)
]
build (LocalPact5PreflightResult cr ws) = J.object
[ "preflightResult" J..= fmap (sshow @_ @Text) cr
, "preflightWarnings" J..= J.Array (J.text <$> ws)
]
build LocalTimeout = J.text "Transaction timed out"
{-# INLINE build #-}

Expand All @@ -807,18 +864,19 @@ instance FromJSON LocalResult where
v
<|> withObject
"LocalResult"
(\o -> metaFailureParser o
<|> localWithWarnParser o
<|> legacyFallbackParser o
(\o ->
metaFailureParser o
<|> localWithWarnParser o
<|> pure (legacyFallbackParser o)
)
v
where
metaFailureParser o =
MetadataValidationFailure <$> o .: "preflightValidationFailure"
localWithWarnParser o = LocalResultWithWarns
<$> o .: "preflightResult"
<$> (J.encodeJsonText @Value <$> o .: "preflightResult")
<*> o .: "preflightWarnings"
legacyFallbackParser _ = LocalResultLegacy <$> parseJSON v
legacyFallbackParser _ = LocalResultLegacy $ J.encodeJsonText v


-- | Used in tests for matching on JSON serialized pact exceptions
Expand Down
9 changes: 7 additions & 2 deletions test/lib/Chainweb/Test/RestAPI/Utils.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -83,6 +83,9 @@ import Pact.Types.Hash
import qualified Pact.Core.Command.Server as Pact5
import qualified Pact.Core.Command.Types as Pact5
import qualified Pact.Types.API as Pact4
import qualified Data.Aeson as Aeson
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy as TL

-- ------------------------------------------------------------------ --
-- Defaults
Expand Down Expand Up @@ -153,9 +156,11 @@ local
-> Command Text
-> IO (CommandResult Hash)
local v sid cenv cmd = do
LocalResultLegacy cr <-
Just cr <- preview _LocalResultLegacy <$>
localWithQueryParams v sid cenv Nothing Nothing Nothing cmd
pure cr
Just pact4Cr <- return $
Aeson.decode (TL.encodeUtf8 $ TL.fromStrict $ J.getJsonText cr)
pure pact4Cr

localTestToRetry
:: ChainwebVersion
Expand Down
23 changes: 16 additions & 7 deletions test/unit/Chainweb/Test/Pact4/PactExec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Module: Chainweb.Test.Pact
Expand Down Expand Up @@ -70,6 +71,9 @@ import Pact.Types.Pretty

import qualified Pact.JSON.Encode as J
import Data.Functor.Product
import qualified Data.Aeson as Aeson
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy as TL

testVersion :: ChainwebVersion
testVersion = slowForkingCpmTestVersion petersonChainGraph
Expand Down Expand Up @@ -572,14 +576,19 @@ execLocalTest runPact name (trans',check) = testCase name (go >>= check)
results' <- tryAny $ runPact $
execLocal (Pact4.unparseTransaction trans) Nothing Nothing Nothing
case results' of
Right (MetadataValidationFailure e) ->
Right (preview _MetadataValidationFailure -> Just e) ->
return $ Left $ show e
Right (preview _LocalTimeout -> Just ()) ->
return $ Left "LocalTimeout"
Right (preview _LocalResultLegacy -> Just cr) -> do
Just decodedCr <- return $ Aeson.decode (TL.encodeUtf8 $ TL.fromStrict $ J.getJsonText cr)
return $ Right decodedCr
Right (preview _LocalResultWithWarns -> Just (cr, _)) -> do
Just decodedCr <- return $ Aeson.decode (TL.encodeUtf8 $ TL.fromStrict $ J.getJsonText cr)
return $ Right decodedCr
Right _ -> error "unknown local result"
Left e ->
return $ Left $ show e
Right LocalTimeout -> return $ Left "LocalTimeout"
Right (LocalResultLegacy cr) -> return $ Right cr
Right (LocalResultWithWarns cr _) -> return $ Right cr
Right (LocalPact5PreflightResult _ _) -> error "Pact 5"
Right (LocalPact5ResultLegacy _) -> error "Pact 5"
Left e -> return $ Left $ show e

getPactCode :: TestSource -> IO Text
getPactCode (Code str) = return (pack str)
Expand Down
Loading

0 comments on commit dedf18a

Please sign in to comment.