From 29775533e087e682285cc418feb416ffe7b39c21 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Fri, 26 Jul 2024 11:36:21 -0700 Subject: [PATCH] batch signatures --- pact-request-api/Pact/Core/Command/Client.hs | 41 +++--- pact-request-api/Pact/Core/Command/Server.hs | 143 ------------------- pact-tng.cabal | 8 +- pact/Pact/Core/StableEncoding.hs | 2 + 4 files changed, 23 insertions(+), 171 deletions(-) delete mode 100644 pact-request-api/Pact/Core/Command/Server.hs diff --git a/pact-request-api/Pact/Core/Command/Client.hs b/pact-request-api/Pact/Core/Command/Client.hs index e32947a59..95709c08c 100644 --- a/pact-request-api/Pact/Core/Command/Client.hs +++ b/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.Capabilities 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.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) @@ -980,15 +977,15 @@ nonemptyVerifiers vs = Just vs -- Parse `APIKeyPair`s into Ed25519 keypairs and WebAuthn keypairs. -- The keypairs must not be prefixed with "WEBAUTHN-", it accepts -- only the raw (unprefixed) keys. -mkKeyPairs :: [ApiKeyPair] -> IO [(DynKeyPair, [CapToken QualifiedName PactValue])] +mkKeyPairs :: [ApiKeyPair] -> IO [(DynKeyPair, [UserCapability])] mkKeyPairs keyPairs = traverse mkPair keyPairs where importValidKeyPair :: Maybe PublicKeyBS -> PrivateKeyBS - -> Maybe [CapToken QualifiedName PactValue] - -> Either String (Ed25519KeyPair, [CapToken QualifiedName PactValue]) + -> Maybe [UserCapability] + -> Either String (Ed25519KeyPair, [UserCapability]) importValidKeyPair pubEd25519 privEd25519 caps = fmap (,maybe [] id caps) $ importEd25519KeyPair pubEd25519 privEd25519 @@ -998,7 +995,7 @@ mkKeyPairs keyPairs = traverse mkPair keyPairs Just ED25519 -> True _ -> False - mkPair :: ApiKeyPair -> IO (DynKeyPair, [CapToken QualifiedName PactValue]) + mkPair :: ApiKeyPair -> IO (DynKeyPair, [UserCapability]) mkPair akp = case (_akpScheme akp, _akpPublic akp, _akpSecret akp, _akpAddress akp) of (scheme, pub, priv, Nothing) | isEd25519 scheme -> either dieAR (return . first DynEd25519KeyPair) (importValidKeyPair pub priv (_akpCaps akp)) diff --git a/pact-request-api/Pact/Core/Command/Server.hs b/pact-request-api/Pact/Core/Command/Server.hs deleted file mode 100644 index 3ca558ec7..000000000 --- a/pact-request-api/Pact/Core/Command/Server.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -import Control.Monad.IO.Class -import Control.Monad.Except -import Control.Concurrent.MVar --- import Data.ByteString -import qualified Data.LruCache as LRU -import Data.IORef -import Data.LruCache.IO as LRU -import Data.Text -import qualified Data.Text.Encoding as E -import Data.Traversable -import Data.Word -import GHC.Generics -import Servant.API -import Servant.Server --- import System.FilePath - -import Pact.Core.Builtin -import Pact.Core.Compile -import Pact.Core.Command.RPC -import Pact.Core.Command.Types -import Pact.Core.ChainData -import Pact.Core.Errors -import Pact.Core.Environment.Types -import Pact.Core.Evaluate --- import Pact.Core.Gas.Types --- import Pact.Core.Info -import Pact.Core.Persistence.Types -import Pact.Core.StableEncoding -import Pact.Core.Syntax.ParseTree -import Pact.Core.Command.Client - -main :: IO () -main = undefined (server undefined) - --- | Commandline configuration for running a Pact server. -data Config = Config { - _port :: Word16, - _persistDir :: Maybe FilePath, - _logDir :: FilePath, - _pragmas :: [Pragma], - _verbose :: Bool, - -- _entity :: Maybe EntityName, - _gasLimit :: Maybe Int, - _gasRate :: Maybe Int - -- _execConfig :: Maybe ExecutionConfig - } deriving (Eq,Show,Generic) - --- | Pragma for configuring a SQLite database. -newtype Pragma = Pragma Text - deriving (Eq, Show, Generic) - --- | Temporarily pretend our Log type in CommandResult is unit. -type Log = () - --- | Runtime environment for a Pact server. -data CommandEnv = CommandEnv { - -- _ceEntity :: Maybe EntityName - _ceMode :: ExecutionMode - , _ceDbEnv :: PactDb CoreBuiltin () - -- , _ceLogger :: Logger - -- , _ceGasEnv :: GasEnv - , _cePublicData :: PublicData - -- , _ceSPVSupport :: SPVSupport - , _ceNetworkId :: Maybe NetworkId - -- , _ceExecutionConfig :: ExecutionConfig - , _ceEvalEnv :: EvalEnv CoreBuiltin () - , _ceEvalState :: MVar (EvalState CoreBuiltin ()) - , _ceRequestCache :: LruHandle RequestKey (CommandResult Log PactErrorI) - } - -type API = - "v1" :> "send" :> ReqBody '[JSON] SubmitBatch :> Post '[JSON] RequestKeys - :<|> "v1" :> "listen" :> Capture "requestKey" RequestKey :> Get '[JSON] (CommandResult Log PactErrorI) - -server :: CommandEnv -> Server API -server env = - sendHandler env - :<|> listenHandler env - -sendHandler :: CommandEnv -> SubmitBatch -> Handler RequestKeys -sendHandler env submitBatch = do - requestKeys <- forM (_sbCmds submitBatch) (\cmd -> liftIO $ do - -- let evalEnv = _ceEvalEnv env - let requestKey = cmdToRequestKey cmd - _ <- cached (_ceRequestCache env) requestKey (computeResultAndUpdateState requestKey cmd) - pure requestKey) - -- TODO, stick result into the cache. - -- TODO, stick result into the cache. - pure $ RequestKeys requestKeys - - where - computeResultAndUpdateState :: RequestKey -> Command Text -> IO (CommandResult Log PactErrorI) - computeResultAndUpdateState requestKey cmd = do - modifyMVar (_ceEvalState env) $ \evalState -> do - case verifyCommand @(StableEncoding PublicMeta) (fmap E.encodeUtf8 cmd) of - ProcFail _ -> error "TODO" - ProcSucc Command{ _cmdPayload = Payload { _pPayload = Exec execMsg }} -> do - let parsedCode = Right $ _pcExps (_pmCode execMsg) - (evalState', result) <- interpretReturningState (_ceEvalEnv env) evalState parsedCode - case result of - Right goodRes -> pure (evalState', evalResultToCommandResult requestKey goodRes) - Left _ -> error "TODO" - ProcSucc Command { _cmdPayload = Payload { _pPayload = Continuation contMsg }} -> do - let evalInput = contMsgToEvalInput contMsg - (evalState', result) <- interpretReturningState (_ceEvalEnv env) evalState evalInput - case result of - Right goodRes -> pure (evalState', evalResultToCommandResult requestKey goodRes) - Left _ -> error "TODO" - - evalResultToCommandResult :: RequestKey -> EvalResult [TopLevel ()] -> CommandResult Log PactErrorI - evalResultToCommandResult requestKey EvalResult {_erOutput, _erLogs, _erExec, _erGas, _erTxId, _erEvents} = - CommandResult { - _crReqKey = requestKey, - _crTxId = _erTxId, - _crResult = evalOutputToCommandResult _erOutput, - _crGas = _erGas, - _crLogs = Nothing, -- TODO - _crEvents = _erEvents, - _crContinuation = Nothing, - _crMetaData = Nothing -- TODO - } - - evalOutputToCommandResult :: [CompileValue ()] -> PactResult PactErrorI - evalOutputToCommandResult = \case - [InterpretValue v _info] -> PactResultOk v - other -> error ("Wanted single InterpretValue. Got\n" ++ show other) - - contMsgToEvalInput :: ContMsg -> EvalInput - contMsgToEvalInput = undefined - -listenHandler :: CommandEnv -> RequestKey -> Handler (CommandResult Log PactErrorI) -listenHandler env key = do - let (LRU.LruHandle cacheRef) = _ceRequestCache env - cache <- liftIO $ readIORef cacheRef - case LRU.lookup key cache of - Just (result, _) -> pure result - Nothing -> throwError err404 \ No newline at end of file diff --git a/pact-tng.cabal b/pact-tng.cabal index dbb0bf9f1..09613f0e6 100644 --- a/pact-tng.cabal +++ b/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 @@ -384,11 +384,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 diff --git a/pact/Pact/Core/StableEncoding.hs b/pact/Pact/Core/StableEncoding.hs index a9a98442c..43b321fc2 100644 --- a/pact/Pact/Core/StableEncoding.hs +++ b/pact/Pact/Core/StableEncoding.hs @@ -591,3 +591,5 @@ instance JD.FromJSON (StableEncoding PublicMeta) where instance J.Encode (StableEncoding a) => J.Encode (StableEncoding (Maybe a)) where build (StableEncoding a) = J.build (StableEncoding <$> a) +-- instance J.Encode (StableEncoding a) => J.Encode (StableEncoding [a]) where +-- build (StableEncoding a) = J.build (J.Array (fmap StableEncoding a))