Pact API upgrade

cabal.project

@@ -9,7 +9,7 @@ package aeson
 source-repository-package
     type: git
     location: https://github.com/kadena-io/pact.git
-    tag: d9a35f6edee1a99cd6f864f68fc3b3b44ce0b4cd
+    tag: 9456a750f67b62d48bed5ef2e60fbc7e9d2a4396
 
 source-repository-package
     type: git

default.nix

@@ -200,8 +200,8 @@ in
         pact = dontCheck ( addBuildDepend (self.callCabal2nix "pact" (pkgs.fetchFromGitHub {
           owner = "kadena-io";
           repo = "pact";
-          rev = "d9a35f6edee1a99cd6f864f68fc3b3b44ce0b4cd";
-          sha256 = "0cxy0azlg9p7zljpxv4fc4hcdizhv48q8cgpwh4557zcii1vbqhk";
+          rev = "9456a750f67b62d48bed5ef2e60fbc7e9d2a4396";
+          sha256 = "039fmgb5d4p524vagmkmmp3gajmvrly7r3iwy9mcdg6j7a6vqj9w";
           }) {}) pkgs.z3);
 
         streaming = callHackageDirect {

src/Chainweb/Pact/PactService.hs

@@ -25,7 +25,6 @@ module Chainweb.Pact.PactService
     , mkPureState
     , serviceRequests
     , createCoinContract
-    , toHashedLogTxOutput
     , initialPayloadState
     , transactionsFromPayload
     , restoreCheckpointer
@@ -196,39 +195,42 @@ serviceRequests memPoolAccess reqQ = do
             LocalMsg LocalReq{..} -> do
                 r <- try $ execLocal _localRequest
                 case r of
-                  Left e -> liftIO $ putMVar _localResultVar $ Left e
-                  Right r' -> liftIO $ putMVar _localResultVar r'
+                  Left (SomeException e) -> liftIO $ putMVar _localResultVar $ toPactInternalError e
+                  Right r' -> liftIO $ putMVar _localResultVar $ Right r'
                 go
             NewBlockMsg NewBlockReq {..} -> do
                 txs <- try $ execNewBlock memPoolAccess _newBlockHeader _newMiner
                 case txs of
                   Left (SomeException e) -> do
                     logError (show e)
-                    liftIO $ putMVar _newResultVar $ Left $ PactInternalError $ T.pack $ show e
+                    liftIO $ putMVar _newResultVar $ toPactInternalError e
                   Right r -> liftIO $ putMVar _newResultVar $ Right r
                 go
             ValidateBlockMsg ValidateBlockReq {..} -> do
                 txs <- try $ execValidateBlock False _valBlockHeader _valPayloadData
                 case txs of
                   Left (SomeException e) -> do
                     logError (show e)
-                    liftIO $ putMVar _valResultVar $ Left $ PactInternalError $ T.pack $ show e
+                    liftIO $ putMVar _valResultVar $ toPactInternalError e
                   Right r ->
                     liftIO $ putMVar _valResultVar $ validateHashes r _valBlockHeader
                 go
+    toPactInternalError e = Left $ PactInternalError $ T.pack $ show e
 
 
 toTransactionBytes :: P.Command ByteString -> Transaction
 toTransactionBytes cwTrans =
     let plBytes = encodeToByteString cwTrans
     in Transaction { _transactionBytes = plBytes }
 
-toOutputBytes :: FullLogTxOutput -> TransactionOutput
-toOutputBytes flOut =
-    let hashedLogOut = toHashedLogTxOutput flOut
-        outBytes = A.encode hashedLogOut
+
+toOutputBytes :: HashCommandResult -> TransactionOutput
+toOutputBytes cr =
+    let outBytes = A.encode cr
     in TransactionOutput { _transactionOutputBytes = toS outBytes }
 
+
+
 toPayloadWithOutputs :: MinerInfo -> Transactions -> PayloadWithOutputs
 toPayloadWithOutputs mi ts =
     let oldSeq = Seq.fromList $ V.toList $ _transactionPairs ts
@@ -244,6 +246,7 @@ toPayloadWithOutputs mi ts =
         plData = payloadData blockTrans blockPL
      in payloadWithOutputs plData cb transOuts
 
+
 validateHashes :: PayloadWithOutputs -> BlockHeader -> Either PactException PayloadWithOutputs
 validateHashes pwo bHeader =
     let newHash = _payloadWithOutputsPayloadHash pwo
@@ -308,7 +311,7 @@ execNewGenesisBlock miner newTrans = do
 
 
 execLocal :: ChainwebTransaction ->
-             PactServiceM (Either SomeException (P.CommandSuccess A.Value))
+             PactServiceM HashCommandResult
 execLocal cmd = do
 
   bh <- use psStateValidated >>= \v -> case v of
@@ -330,7 +333,7 @@ execLocal cmd = do
 
   discardCheckpointer
 
-  return (fmap (\(P.CommandSuccess t) -> P.CommandSuccess (A.toJSON t)) r)
+  return $! toHashCommandResult r
 
 
 
@@ -407,28 +410,25 @@ runCoinbase
     :: Maybe BlockHash
     -> Env'
     -> MinerInfo
-    -> PactServiceM FullLogTxOutput
+    -> PactServiceM HashCommandResult
 runCoinbase Nothing _ _ = return noCoinbase
-runCoinbase (Just parentHash) (Env' dbEnv) mi@MinerInfo{..} = do
+runCoinbase (Just _parentHash) (Env' dbEnv) mi@MinerInfo{..} = do
   psEnv <- ask
 
   let reward = 42.0 -- TODO. Not dispatching on chainweb version yet as E's PR will have PublicData
       pd = _psPublicData psEnv
       logger = _cpeLogger . _psCheckpointEnv $ psEnv
 
-  (result, txLogs) <- liftIO $ applyCoinbase logger dbEnv mi reward pd
-
-  let output = A.object [ "result" A..= P._crResult result, "parentHash" A..= parentHash]
+  toHashCommandResult <$> liftIO (applyCoinbase logger dbEnv mi reward pd)
 
-  pure $! FullLogTxOutput output txLogs
 
 -- | Apply multiple Pact commands, incrementing the transaction Id for each
 applyPactCmds
     :: Bool
     -> Env'
     -> Vector (P.Command PayloadWithText)
     -> MinerInfo
-    -> PactServiceM (Vector FullLogTxOutput)
+    -> PactServiceM (Vector HashCommandResult)
 applyPactCmds isGenesis env' cmds miner = V.mapM f cmds
   where
       f cmd = applyPactCmd isGenesis env' cmd miner
@@ -439,7 +439,7 @@ applyPactCmd
     -> Env'
     -> P.Command PayloadWithText
     -> MinerInfo
-    -> PactServiceM FullLogTxOutput
+    -> PactServiceM HashCommandResult
 applyPactCmd isGenesis (Env' dbEnv) cmdIn miner = do
     psEnv <- ask
     let logger   = _cpeLogger . _psCheckpointEnv $ psEnv
@@ -449,11 +449,14 @@ applyPactCmd isGenesis (Env' dbEnv) cmdIn miner = do
 
     -- cvt from Command PayloadWithTexts to Command ((Payload PublicMeta ParsedCode)
     let cmd = payloadObj <$> cmdIn
-    (result, txLogs) <- liftIO $! if isGenesis
+    result <- liftIO $! if isGenesis
         then applyGenesisCmd logger dbEnv pd spv cmd
         else applyCmd logger dbEnv miner gasModel pd spv cmd
 
-    pure $! FullLogTxOutput (P._crResult result) txLogs
+    pure $! toHashCommandResult result
+
+toHashCommandResult :: P.CommandResult [P.TxLog A.Value] -> HashCommandResult
+toHashCommandResult = over (P.crLogs . _Just) (P.pactHash . encodeToByteString)
 
 updateState :: PactDbState  -> PactServiceM ()
 updateState = assign psStateDb

src/Chainweb/Pact/RestAPI.hs

@@ -9,10 +9,7 @@ module Chainweb.Pact.RestAPI where
 
 ------------------------------------------------------------------------------
 import Control.Monad.Identity
-import Data.Aeson.Types
-import Data.Text (Text)
-import Pact.Types.API
-import Pact.Types.Command
+import Pact.Server.API as API
 import Servant
 ------------------------------------------------------------------------------
 import Chainweb.ChainId
@@ -23,14 +20,7 @@ import Chainweb.Version
 -- -------------------------------------------------------------------------- --
 -- @GET /chainweb/<ApiVersion>/<ChainwebVersion>/chain/<ChainId>/pact/@
 
-type ApiV1API = SendApi :<|> PollApi :<|> ListenApi :<|> LocalApi
-
-type SendApi = "send" :> ReqBody '[JSON] SubmitBatch :> Post '[JSON] RequestKeys
-type PollApi = "poll" :> ReqBody '[JSON] Poll :> Post '[JSON] PollResponses
-type ListenApi = "listen" :> ReqBody '[JSON] ListenerRequest :> Post '[JSON] ApiResult
-type LocalApi = "local" :> ReqBody '[JSON] (Command Text) :> Post '[JSON] (CommandSuccess Value)
-
-type PactApi_ = "pact" :> ApiV1API
+type PactApi_ = "pact" :> API.ApiV1API -- TODO unify with Pact versioning
 
 type PactApi (v :: ChainwebVersionT) (c :: ChainIdT)
     = 'ChainwebEndpoint v :> ChainEndpoint c :> Reassoc PactApi_

src/Chainweb/Pact/RestAPI/Orphans.hs

@@ -3,34 +3,31 @@
 
 module Chainweb.Pact.RestAPI.Orphans () where
 
-import Data.Aeson
 import Data.Swagger
+import Data.Text (Text)
 import Pact.Types.API
 import Pact.Types.Command
 
-instance ToSchema (CommandSuccess a) where
-  declareNamedSchema _ = return $ NamedSchema (Just "CommandSuccess") mempty
+instance ToSchema (CommandResult a) where
+  declareNamedSchema = simpleNS "CommandResult"
 
 instance ToSchema (Command a) where
-  declareNamedSchema _ = return $ NamedSchema (Just "Command") mempty
-
-instance ToSchema Value where
-  declareNamedSchema _ = return $ NamedSchema (Just "Value") mempty
-
-instance ToSchema ApiResult where
-  declareNamedSchema _ = return $ NamedSchema (Just "ApiResult") mempty
+  declareNamedSchema = simpleNS "Command"
 
 instance ToSchema ListenerRequest where
-  declareNamedSchema _ = return $ NamedSchema (Just "ListenerRequest") mempty
+  declareNamedSchema = simpleNS "ListenerRequest"
 
 instance ToSchema PollResponses where
-  declareNamedSchema _ = return $ NamedSchema (Just "PollResponses") mempty
+  declareNamedSchema = simpleNS "PollResponses"
 
 instance ToSchema Poll where
-  declareNamedSchema _ = return $ NamedSchema (Just "Poll") mempty
+  declareNamedSchema = simpleNS "Poll"
 
 instance ToSchema RequestKeys where
-  declareNamedSchema _ = return $ NamedSchema (Just "RequestKeys") mempty
+  declareNamedSchema = simpleNS "RequestKeys"
 
 instance ToSchema SubmitBatch where
-  declareNamedSchema _ = return $ NamedSchema (Just "SubmitBatch") mempty
+  declareNamedSchema = simpleNS "SubmitBatch"
+
+simpleNS :: Monad m => Text -> p -> m NamedSchema
+simpleNS n _ = return $ NamedSchema (Just n) mempty

src/Chainweb/Pact/RestAPI/Server.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
@@ -42,6 +43,7 @@ import qualified GHC.Event as Ev
 import qualified Pact.Types.Hash as H
 import Pact.Types.API
 import Pact.Types.Command
+import Pact.Types.Hash
 import Prelude hiding (init, lookup)
 import Servant
 
@@ -154,25 +156,26 @@ listenHandler
     -> ChainResources logger
     -> TransactionBloomCache
     -> ListenerRequest
-    -> Handler ApiResult
+    -> Handler (CommandResult Hash)
 listenHandler cutR cid chain bloomCache (ListenerRequest key) =
-    liftIO $ handleTimeout runListen
+    liftIO (handleTimeout runListen) >>= handleResult
   where
-    nullResponse = ApiResult (object []) Nothing Nothing
+    handleResult (Right r) = return r
+    handleResult _ = throwError $ err400 { errBody = "Timeout" }
 
     runListen timedOut = go Nothing
       where
         go !prevCut = do
             m <- waitForNewCut prevCut
             case m of
-                Nothing -> return nullResponse      -- timeout
+                Nothing -> return $ Left ()      -- timeout
                 (Just cut) -> poll cut
 
         poll cut = do
             hm <- internalPoll cutR cid chain bloomCache cut [key]
             if HashMap.null hm
               then go (Just cut)
-              else return $! snd $ head $ HashMap.toList hm
+              else return $! Right $ snd $ head $ HashMap.toList hm
 
         waitForNewCut lastCut = atomically $ do
              -- TODO: we should compute greatest common ancestor here to bound the
@@ -206,7 +209,7 @@ localHandler
     -> ChainId
     -> ChainResources logger
     -> Command Text
-    -> Handler (CommandSuccess Value)
+    -> Handler (CommandResult Hash)
 localHandler _ _ cr cmd = do
   cmd' <- case validateCommand cmd of
     Right c -> return c
@@ -229,11 +232,11 @@ internalPoll
     -> TransactionBloomCache
     -> Cut
     -> [RequestKey]
-    -> IO (HashMap RequestKey ApiResult)
+    -> IO (HashMap RequestKey (CommandResult Hash))
 internalPoll cutR cid chain bloomCache cut requestKeys =
     toHashMap <$> mapM lookup requestKeys
   where
-    lookup :: RequestKey -> IO (Maybe (RequestKey, ApiResult))
+    lookup :: RequestKey -> IO (Maybe (RequestKey, CommandResult Hash))
     lookup key =
         fmap (key,) <$> lookupRequestKey cid cut cutR chain bloomCache key
     toHashMap = HashMap.fromList . catMaybes
@@ -247,7 +250,7 @@ lookupRequestKey
     -> ChainResources logger
     -> TransactionBloomCache
     -> RequestKey
-    -> IO (Maybe ApiResult)
+    -> IO (Maybe (CommandResult Hash))
 lookupRequestKey cid cut cutResources chain bloomCache key = do
     -- get leaf block header for our chain from current best cut
     chainLeaf <- lookupCutM cid cut
@@ -273,7 +276,7 @@ lookupRequestKeyInBlock
     -> RequestKey               -- ^ key to search
     -> BlockHeight              -- ^ lowest block to search
     -> BlockHeader              -- ^ search starts here
-    -> MaybeT IO ApiResult
+    -> MaybeT IO (CommandResult Hash)
 lookupRequestKeyInBlock cutR chain bloomCache key minHeight = go
   where
     keyHash :: H.Hash
@@ -298,12 +301,8 @@ lookupRequestKeyInBlock cutR chain bloomCache key minHeight = go
         case find matchingHash txs of
             (Just (_cmd, (TransactionOutput output))) -> do
 
-                -- this will be a HashedTxLogOutput containing a Value of
-                -- of `CommandSuccess` or `CommandFailure`.
-                -- The metadata could be used to track request time, chain metadata etc.
-
                 val <- MaybeT $ return $ decodeStrict output
-                return $! ApiResult val Nothing Nothing
+                return $! val
 
             Nothing -> lookupParent blockHeader
 

src/Chainweb/Pact/SPV.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -92,16 +93,17 @@ pactSPV cdbv l = SPVSupport $ \s o -> readMVar cdbv >>= go s o
 
     extractOutputs :: TransactionOutput -> IO (Either Text (Object Name))
     extractOutputs (TransactionOutput t) =
-      case decodeStrict t of
+      case decodeStrict t :: Maybe HashCommandResult of
         Nothing -> internalError $
           "unable to decode spv transaction output"
-        Just (HashedLogTxOutput u _) ->
-          case fromJSON u of
-            Error e -> spvError' e
-            Success (CommandSuccess (TObject o _)) -> return $ Right o
-            Success o -> do
-              logLog l "ERROR" $ show o
-              internalError "associated pact transaction outputs have wrong format"
+        Just (CommandResult _ _ (PactResult (Right pv)) _ _ _ _) -> case fromPactValue pv of
+          (TObject o _) -> return $ Right o
+          o -> do
+            logLog l "ERROR" $ show o
+            spvError' "associated pact transaction outputs have wrong format"
+        Just o -> do
+          logLog l "ERROR" $ show o
+          spvError' "associated pact transaction outputs have wrong format"
 
 
 -- | Look up pact tx hash at some block height in the

src/Chainweb/Pact/Service/BlockValidation.hs

@@ -25,13 +25,11 @@ import Chainweb.Pact.Service.PactQueue
 import Chainweb.Pact.Service.Types
 import Chainweb.Pact.Types
 import Chainweb.Payload
-import Pact.Types.Command
-import Data.Aeson (Value)
-import Control.Exception
 import Chainweb.Transaction
 
 
-newBlock :: MinerInfo -> BlockHeader -> TQueue RequestMsg -> IO (MVar (Either PactException PayloadWithOutputs))
+newBlock :: MinerInfo -> BlockHeader -> TQueue RequestMsg ->
+            IO (MVar (Either PactException PayloadWithOutputs))
 newBlock mi bHeader reqQ = do
     resultVar <- newEmptyMVar :: IO (MVar (Either PactException PayloadWithOutputs))
     let msg = NewBlockMsg NewBlockReq
@@ -55,7 +53,7 @@ validateBlock bHeader plData reqQ = do
     addRequest reqQ msg
     return resultVar
 
-local :: ChainwebTransaction -> TQueue RequestMsg -> IO (MVar (Either SomeException (CommandSuccess Value)))
+local :: ChainwebTransaction -> TQueue RequestMsg -> IO (MVar (Either PactException HashCommandResult))
 local ct reqQ = do
     resultVar <- newEmptyMVar
     let msg = LocalMsg LocalReq