From 2dee0a2f44dcc19b1eb38e5237b1350c03083689 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Tue, 28 Mar 2023 13:40:57 -0700 Subject: [PATCH 01/26] Add enforceKeysetSession to Eval.hs --- src/Pact/Eval.hs | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/src/Pact/Eval.hs b/src/Pact/Eval.hs index 545ec701d..bcf949ea3 100644 --- a/src/Pact/Eval.hs +++ b/src/Pact/Eval.hs @@ -146,6 +146,39 @@ enforceKeySet i ksn KeySet{..} = do | otherwise = failed {-# INLINE enforceKeySet #-} +-- | Enforce keyset against session key from the environment. +enforceKeySetSession :: PureSysOnly e => Info -> Maybe KeySetName -> KeySet -> Eval e () +enforceKeySetSession i ksn KeySet{..} = do + sigs <- maybeToMap <$> (view eeSessionSig) + sigs' <- checkSigCaps sigs + runPred (M.size sigs') + where + maybeToMap mayKV = + maybe M.empty (\(k,v) -> if k `elem` _ksKeys + then M.singleton k v + else M.empty) mayKV + failed = failTx i $ "Keyset failure " <> parens (pretty _ksPredFun) <> ": " <> + maybe (pretty $ map (elide . asString) $ toList _ksKeys) pretty ksn + atLeast t m = m >= t + elide pk | T.length pk < 8 = pk + | otherwise = T.take 8 pk <> "..." + count = length _ksKeys + runPred matched = + case M.lookup _ksPredFun keyPredBuiltins of + Just KeysAll -> runBuiltIn (\c m -> atLeast c m) + Just KeysAny -> runBuiltIn (\_ m -> atLeast 1 m) + Just Keys2 -> runBuiltIn (\_ m -> atLeast 2 m) + Nothing -> do + r <- evalByName _ksPredFun [toTerm count,toTerm matched] i + case r of + (TLiteral (LBool b) _) | b -> return () + | otherwise -> failed + _ -> evalError i $ "Invalid response from keyset predicate: " <> pretty r + where + runBuiltIn p | p count matched = return () + | otherwise = failed +{-# INLINE enforceKeySetSession #-} + enforceGuard :: HasInfo i => i -> Guard (Term Name) -> Eval e () enforceGuard i g = case g of GKeySet k -> runSysOnly $ enforceKeySet (getInfo i) Nothing k From a74509f8917841f96d43b50bf31af35722586459 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Tue, 28 Mar 2023 13:42:36 -0700 Subject: [PATCH 02/26] Add enforce-session builtin --- src/Pact/Native/Session.hs | 69 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) create mode 100644 src/Pact/Native/Session.hs diff --git a/src/Pact/Native/Session.hs b/src/Pact/Native/Session.hs new file mode 100644 index 000000000..5b3a6d536 --- /dev/null +++ b/src/Pact/Native/Session.hs @@ -0,0 +1,69 @@ +-- | +-- Module : Pact.Native.Session +-- Copyright : (C) 2016 Stuart Popejoy +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Stuart Popejoy +-- +-- Builtins for working with sessions. +-- + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Pact.Native.Session (sessionDefs, enforceSessionDef) where + + +import Pact.Eval (enforceKeySetSession) +import Pact.Native.Internal(NativeDef, NativeModule, defRNative, funType, tTyBool, tTyGuard, tTyString) +import Pact.Types.KeySet (KeySetName(..), parseAnyKeysetName) +import Pact.Types.Native (RNativeFun) +import Pact.Types.Pretty (pretty) +import Pact.Types.Purity (PureSysOnly, runSysOnly) +import Pact.Types.Runtime (getInfo, evalError, evalError', ifExecutionFlagSet, ExecutionFlag(FlagDisablePact44), readRow, Domain(KeySets), argsError) +import Pact.Types.Term (Example(LitExample), Guard(GKeySet, GKeySetRef), pattern TLitString, Term(TGuard), _tGuard, toTerm) +import Pact.Types.Type (GuardType(GTyKeySet)) + +sessionDefs :: NativeModule +sessionDefs = + ("Session",[enforceSessionDef]) + +enforceSessionDef :: NativeDef +enforceSessionDef = + defRNative "enforce-session" (\i as -> runSysOnly $ enforceSession' i as) + (funType tTyBool [("keyset", tTyGuard (Just GTyKeySet))] + <> funType tTyBool [("keysetname",tTyString)] + ) + [LitExample "(enforce-session keyset)"] + "Enforce that the current environment contains a session signer with a key \ + \that satisfies the keyset parameter. The execution environment is \ + \responsible for setting the session signer, usually in response to an \ + \authorization flow." + where + + lookupEnvironmentKeyset i keySetName = do + readRow (getInfo i) KeySets keySetName >>= \case + Nothing -> evalError (getInfo i) $ "No such keyset: " <> pretty keySetName + Just keySet -> pure keySet + + enforceSession' :: PureSysOnly e => RNativeFun e + enforceSession' i [TGuard{_tGuard}] = case _tGuard of + GKeySetRef (ksr) -> do + ks <- lookupEnvironmentKeyset i ksr + enforceKeySetSession (getInfo i) Nothing ks >> return (toTerm True) + GKeySet ks -> enforceKeySetSession (getInfo i) Nothing ks >> return (toTerm True) + _ -> evalError' i "incorrect guard type, must be keyset ref or keyset" + enforceSession' i [TLitString k] = do + keySetName <- ifExecutionFlagSet FlagDisablePact44 + (pure $ KeySetName k Nothing) + (case parseAnyKeysetName k of + Left{} -> evalError' i "incorrect keyset name format" + Right ksn -> return ksn + ) + ks <- readRow (getInfo i) KeySets keySetName >>= \case + Nothing -> evalError (getInfo i) $ "No such keyset: " <> pretty keySetName + Just ks -> pure ks + enforceKeySetSession (getInfo i) (Just keySetName) ks >> return (toTerm True) + + enforceSession' i as = argsError i as From 625a50ade3effed289664cb2e0600a94d5d59e7c Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Tue, 28 Mar 2023 14:27:55 -0700 Subject: [PATCH 03/26] add repl test --- tests/pact/session.repl | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 tests/pact/session.repl diff --git a/tests/pact/session.repl b/tests/pact/session.repl new file mode 100644 index 000000000..c02b49c56 --- /dev/null +++ b/tests/pact/session.repl @@ -0,0 +1,24 @@ +;; +;; session.repl: test setting the session keyset +;; + +(env-exec-config ["DisablePact44"]) + +;; Inject the public key "my-key" into the environment's session. +(env-session "my-key" []) + +;; Populate the environment with two keysets. +(env-data { "keyset": ["my-key"], "bad-keyset": ["other-key"] }) +(define-keyset 'k (read-keyset "keyset")) +(define-keyset 'bad-keyset (read-keyset "bad-keyset")) + +;; Enforcing the session against the first keyset (which the session +;; key satisfies) should succeed. +(expect "session satisfies the keyset 'k" + (enforce-session 'k) + true) + +;; Enforcing the session against a keyset that isn't satisfied +;; by the session key should fail. +(expect-failure "session key is not in bad-keyset" + (enforce-session 'bad-keyset)) From 9d8e9b534449fc0bc99646fd54c1775a285cb3a7 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Tue, 28 Mar 2023 14:40:16 -0700 Subject: [PATCH 04/26] add sessionsigner to setupevalenv --- src-ghc/Pact/Interpreter.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src-ghc/Pact/Interpreter.hs b/src-ghc/Pact/Interpreter.hs index 1327a8692..b345445c4 100644 --- a/src-ghc/Pact/Interpreter.hs +++ b/src-ghc/Pact/Interpreter.hs @@ -171,10 +171,10 @@ setupEvalEnv -> IO (EvalEnv e) setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do gasRef <- newIORef 0 - warnRef <- newIORef mempty pure EvalEnv { _eeRefStore = refStore , _eeMsgSigs = mkMsgSigs $ mdSigners msgData + , _eeSessionSig = toPair <$> mdSessionSigner msgData , _eeMsgBody = mdData msgData , _eeMode = mode , _eeEntity = ent @@ -191,15 +191,12 @@ setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do , _eeExecutionConfig = ec , _eeAdvice = def , _eeInRepl = False - , _eeWarnings = warnRef } where mkMsgSigs ss = M.fromList $ map toPair ss + toPair Signer{..} = (pk,S.fromList _siCapList) where - toPair Signer{..} = (pk,S.fromList _siCapList) - where - pk = PublicKeyText $ fromMaybe _siPubKey _siAddress - + pk = PublicKeyText $ fromMaybe _siPubKey _siAddress initRefStore :: RefStore initRefStore = RefStore nativeDefs From 31a425b7607d1ed17e341b1fbf878d6f71483fe5 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Tue, 28 Mar 2023 15:21:50 -0700 Subject: [PATCH 05/26] fixup --- src/Pact/Repl.hs | 1 + src/Pact/Types/Purity.hs | 1 + src/Pact/Types/Runtime.hs | 4 +++- 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Pact/Repl.hs b/src/Pact/Repl.hs index b5178b85c..86953b733 100644 --- a/src/Pact/Repl.hs +++ b/src/Pact/Repl.hs @@ -148,6 +148,7 @@ initEvalEnv ls = do , _eeGas = gasRef , _eeNamespacePolicy = permissiveNamespacePolicy , _eeSPVSupport = spvs mv + , _eeSessionSig = Nothing , _eePublicData = def , _eeExecutionConfig = def , _eeAdvice = def diff --git a/src/Pact/Types/Purity.hs b/src/Pact/Types/Purity.hs index 72a8bf5b7..b59735688 100644 --- a/src/Pact/Types/Purity.hs +++ b/src/Pact/Types/Purity.hs @@ -73,6 +73,7 @@ mkPureEnv holder purity readRowImpl env@EvalEnv{..} = do return $ EvalEnv _eeRefStore _eeMsgSigs + _eeSessionSig _eeMsgBody _eeMode _eeEntity diff --git a/src/Pact/Types/Runtime.hs b/src/Pact/Types/Runtime.hs index 372414096..a144a3d29 100644 --- a/src/Pact/Types/Runtime.hs +++ b/src/Pact/Types/Runtime.hs @@ -28,7 +28,7 @@ module Pact.Types.Runtime PactId(..), PactEvent(..), eventName, eventParams, eventModule, eventModuleHash, RefStore(..),rsNatives, - EvalEnv(..),eeRefStore,eeMsgSigs,eeMsgBody,eeMode,eeEntity,eePactStep,eePactDbVar,eeInRepl, + EvalEnv(..),eeRefStore,eeMsgSigs,eeSessionSig,eeMsgBody,eeMode,eeEntity,eePactStep,eePactDbVar,eeInRepl, eePactDb,eePurity,eeHash,eeGas, eeGasEnv,eeNamespacePolicy,eeSPVSupport,eePublicData,eeExecutionConfig, eeAdvice, eeWarnings, toPactId, @@ -219,6 +219,8 @@ data EvalEnv e = EvalEnv { _eeRefStore :: !RefStore -- | Verified keys from message. , _eeMsgSigs :: !(M.Map PublicKeyText (S.Set UserCapability)) + -- | Verified session key from message. + , _eeSessionSig :: !(Maybe (PublicKeyText, S.Set UserCapability)) -- | JSON body accompanying message. , _eeMsgBody :: !Value -- | Execution mode From 1e291824637fc99ac60f96835c74b6b4675d25e8 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Tue, 28 Mar 2023 16:39:56 -0700 Subject: [PATCH 06/26] export --- pact.cabal | 1 + src/Pact/Eval.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/pact.cabal b/pact.cabal index fc8b4dc47..c04e49bd0 100644 --- a/pact.cabal +++ b/pact.cabal @@ -86,6 +86,7 @@ library Pact.Native.Guards Pact.Native.Db Pact.Native.Internal + Pact.Native.Session Pact.Native.SPV Pact.Native.Time Pact.Native.Ops diff --git a/src/Pact/Eval.hs b/src/Pact/Eval.hs index bcf949ea3..697a2cd69 100644 --- a/src/Pact/Eval.hs +++ b/src/Pact/Eval.hs @@ -41,6 +41,7 @@ module Pact.Eval ,acquireModuleAdmin ,computeUserAppGas,prepareUserAppArgs,evalUserAppBody ,evalByName + ,enforceKeySetSession ,resumePact ,enforcePactValue,enforcePactValue' ,toPersistDirect From 05ae94e4f6c29d3f074255fa30450f0b15833715 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Wed, 29 Mar 2023 12:52:23 -0700 Subject: [PATCH 07/26] Thread session-signer through payload and update tests --- docs/en/pact-functions.md | 22 ++++++++++++++++++++++ src-ghc/Pact/Bench.hs | 7 ++++--- src-ghc/Pact/Interpreter.hs | 7 +++++-- src-ghc/Pact/Server/PactService.hs | 16 ++++++++-------- src/Pact/Native.hs | 2 ++ src/Pact/Repl.hs | 2 +- src/Pact/Repl/Lib.hs | 12 ++++++++++++ src/Pact/Types/Command.hs | 7 ++++--- tests/GoldenSpec.hs | 2 +- tests/SchemeSpec.hs | 2 +- 10 files changed, 60 insertions(+), 19 deletions(-) diff --git a/docs/en/pact-functions.md b/docs/en/pact-functions.md index a1fa73c64..637cef2ed 100644 --- a/docs/en/pact-functions.md +++ b/docs/en/pact-functions.md @@ -1773,6 +1773,20 @@ pact> (scalar-mult 'g1 {'x: 1, 'y: 2} 2) {"x": 1368015179489954701390400359078579693043519447331113978918064868415326638035,"y": 9918110051302171585080402603319702774565515993150576347155970296011118125764} ``` +## Session {#Session} + +### enforce-session {#enforce-session} + +*keyset* `keyset` *→* `bool` + +*keysetname* `string` *→* `bool` + + +Enforce that the current environment contains a session signer with a key that satisfies the keyset parameter. The execution environment is responsible for setting the session signer, usually in response to an authorization flow. +```lisp +(enforce-session keyset) +``` + ## REPL-only functions {#repl-lib} The following functions are loaded automatically into the interactive REPL, or within script files with a `.repl` extension. They are not available for blockchain-based execution. @@ -2028,6 +2042,14 @@ Install a managed namespace policy specifying ALLOW-ROOT and NS-POLICY-FUN. ``` +### env-session {#env-session} + +*public-key* `string` *caps* `[string]` *→* `string` + + + + + ### env-sigs {#env-sigs} *sigs* `[object:*]` *→* `string` diff --git a/src-ghc/Pact/Bench.hs b/src-ghc/Pact/Bench.hs index 8180b59b5..dca3f3069 100644 --- a/src-ghc/Pact/Bench.hs +++ b/src-ghc/Pact/Bench.hs @@ -156,6 +156,7 @@ loadBenchModule db = do Nothing pactInitialHash [Signer Nothing pk Nothing []] + Nothing let ec = ExecutionConfig $ S.fromList [FlagDisablePact44] e <- setupEvalEnv db entity Transactional md initRefStore freeGasEnv permissiveNamespacePolicy noSPVSupport def ec @@ -183,7 +184,7 @@ benchNFIO bname = bench bname . nfIO runPactExec :: Advice -> String -> [Signer] -> Value -> Maybe (ModuleData Ref) -> PactDbEnv e -> ParsedCode -> IO [PactValue] runPactExec pt msg ss cdata benchMod dbEnv pc = do - let md = MsgData cdata Nothing pactInitialHash ss + let md = MsgData cdata Nothing pactInitialHash ss Nothing ec = ExecutionConfig $ S.fromList [FlagDisablePact44] e <- fmap (set eeAdvice pt) $ setupEvalEnv dbEnv entity Transactional md initRefStore prodGasEnv permissiveNamespacePolicy noSPVSupport def ec @@ -195,7 +196,7 @@ runPactExec pt msg ss cdata benchMod dbEnv pc = do execPure :: Advice -> PactDbEnv e -> (String,[Term Name]) -> IO [Term Name] execPure pt dbEnv (n,ts) = do - let md = MsgData Null Nothing pactInitialHash [] + let md = MsgData Null Nothing pactInitialHash [] Nothing ec = ExecutionConfig $ S.fromList [FlagDisablePact44] env <- fmap (set eeAdvice pt) $ setupEvalEnv dbEnv entity Local md initRefStore prodGasEnv permissiveNamespacePolicy noSPVSupport def ec @@ -236,7 +237,7 @@ mkBenchCmd :: [SomeKeyPairCaps] -> (String, Text) -> IO (String, Command ByteStr mkBenchCmd kps (str, t) = do cmd <- mkCommand' kps $ toStrict . encode - $ Payload payload "nonce" () ss Nothing + $ Payload payload "nonce" () ss Nothing Nothing return (str, cmd) where payload = Exec $ ExecMsg t Null diff --git a/src-ghc/Pact/Interpreter.hs b/src-ghc/Pact/Interpreter.hs index b345445c4..6fbb45250 100644 --- a/src-ghc/Pact/Interpreter.hs +++ b/src-ghc/Pact/Interpreter.hs @@ -78,12 +78,13 @@ data MsgData = MsgData { mdData :: !Value, mdStep :: !(Maybe PactStep), mdHash :: !Hash, - mdSigners :: [Signer] + mdSigners :: [Signer], + mdSessionSigner :: Maybe Signer } initMsgData :: Hash -> MsgData -initMsgData h = MsgData Null def h def +initMsgData h = MsgData Null def h def def -- | Describes either a ContMsg or ExecMsg. -- ContMsg is represented as a 'Maybe PactExec' @@ -171,6 +172,7 @@ setupEvalEnv -> IO (EvalEnv e) setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do gasRef <- newIORef 0 + warnRef <- newIORef mempty pure EvalEnv { _eeRefStore = refStore , _eeMsgSigs = mkMsgSigs $ mdSigners msgData @@ -191,6 +193,7 @@ setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do , _eeExecutionConfig = ec , _eeAdvice = def , _eeInRepl = False + , _eeWarnings = warnRef } where mkMsgSigs ss = M.fromList $ map toPair ss diff --git a/src-ghc/Pact/Server/PactService.hs b/src-ghc/Pact/Server/PactService.hs index b2a73083e..1892fcd4e 100644 --- a/src-ghc/Pact/Server/PactService.hs +++ b/src-ghc/Pact/Server/PactService.hs @@ -141,17 +141,17 @@ fullToHashLogCr full = (pactHash . BSL.toStrict . encode) full runPayload :: Command (Payload PublicMeta ParsedCode) -> CommandM p (CommandResult Hash) runPayload c@Command{..} = case (_pPayload _cmdPayload) of - Exec pm -> applyExec (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) pm - Continuation ym -> applyContinuation (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) ym + Exec pm -> applyExec (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) (_pSessionSigner _cmdPayload) pm + Continuation ym -> applyContinuation (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) (_pSessionSigner _cmdPayload) ym -applyExec :: RequestKey -> PactHash -> [Signer] -> ExecMsg ParsedCode -> CommandM p (CommandResult Hash) -applyExec rk hsh signers (ExecMsg parsedCode edata) = do +applyExec :: RequestKey -> PactHash -> [Signer] -> Maybe Signer -> ExecMsg ParsedCode -> CommandM p (CommandResult Hash) +applyExec rk hsh signers sessionSigner (ExecMsg parsedCode edata) = do CommandEnv {..} <- ask when (null (_pcExps parsedCode)) $ throwCmdEx "No expressions found" evalEnv <- liftIO $ setupEvalEnv _ceDbEnv _ceEntity _ceMode - (MsgData edata Nothing (toUntypedHash hsh) signers) + (MsgData edata Nothing (toUntypedHash hsh) signers sessionSigner) initRefStore _ceGasEnv permissiveNamespacePolicy _ceSPVSupport _cePublicData _ceExecutionConfig EvalResult{..} <- liftIO $ evalExec defaultInterpreter evalEnv parsedCode @@ -159,12 +159,12 @@ applyExec rk hsh signers (ExecMsg parsedCode edata) = do return $ resultSuccess _erTxId rk _erGas (last _erOutput) _erExec _erLogs _erEvents -applyContinuation :: RequestKey -> PactHash -> [Signer] -> ContMsg -> CommandM p (CommandResult Hash) -applyContinuation rk hsh signers cm = do +applyContinuation :: RequestKey -> PactHash -> [Signer] -> Maybe Signer -> ContMsg -> CommandM p (CommandResult Hash) +applyContinuation rk hsh signers sessionSigner cm = do CommandEnv{..} <- ask -- Setup environment and get result evalEnv <- liftIO $ setupEvalEnv _ceDbEnv _ceEntity _ceMode - (MsgData (_cmData cm) Nothing (toUntypedHash hsh) signers) initRefStore + (MsgData (_cmData cm) Nothing (toUntypedHash hsh) signers sessionSigner) initRefStore _ceGasEnv permissiveNamespacePolicy _ceSPVSupport _cePublicData _ceExecutionConfig EvalResult{..} <- liftIO $ evalContinuation defaultInterpreter evalEnv cm return $ resultSuccess _erTxId rk _erGas (last _erOutput) _erExec _erLogs _erEvents diff --git a/src/Pact/Native.hs b/src/Pact/Native.hs index 6e985eb84..0fb58fde2 100644 --- a/src/Pact/Native.hs +++ b/src/Pact/Native.hs @@ -93,6 +93,7 @@ import Pact.Native.Internal import Pact.Native.Keysets import Pact.Native.Ops import Pact.Native.SPV +import Pact.Native.Session (sessionDefs) import Pact.Native.Time import Pact.Native.Pairing(zkDefs) import Pact.Parse @@ -119,6 +120,7 @@ natives = , decryptDefs , guardDefs , zkDefs + , sessionDefs ] diff --git a/src/Pact/Repl.hs b/src/Pact/Repl.hs index 86953b733..17655a511 100644 --- a/src/Pact/Repl.hs +++ b/src/Pact/Repl.hs @@ -136,6 +136,7 @@ initEvalEnv ls = do return $ EvalEnv { _eeRefStore = RefStore nativeDefs , _eeMsgSigs = mempty + , _eeSessionSig = Nothing , _eeMsgBody = Null , _eeMode = Transactional , _eeEntity = Nothing @@ -148,7 +149,6 @@ initEvalEnv ls = do , _eeGas = gasRef , _eeNamespacePolicy = permissiveNamespacePolicy , _eeSPVSupport = spvs mv - , _eeSessionSig = Nothing , _eePublicData = def , _eeExecutionConfig = def , _eeAdvice = def diff --git a/src/Pact/Repl/Lib.hs b/src/Pact/Repl/Lib.hs index e599be49a..494fdd964 100644 --- a/src/Pact/Repl/Lib.hs +++ b/src/Pact/Repl/Lib.hs @@ -126,6 +126,9 @@ replDefs = ("Repl", "{'key: \"admin-key\", 'caps: []}"] ("Set transaction signature keys and capabilities. SIGS is a list of objects with \"key\" " <> "specifying the signer key, and \"caps\" specifying a list of associated capabilities.") + ,defZNative "env-session" setsession (funType tTyString [("public-key", tTyString), ("caps", TyList tTyString)]) + [] + "" ,defZRNative "env-data" setmsg (funType tTyString [("json",json)]) ["(env-data { \"keyset\": { \"keys\": [\"my-key\" \"admin-key\"], \"pred\": \"keys-any\" } })"] @@ -402,6 +405,15 @@ setmsg i as = case as of _ -> argsError i as where go v = setenv eeMsgBody v >> return (tStr "Setting transaction data") +setsession :: ZNativeFun LibState +setsession _ [TLitString publicKey, TList caps _ _] = do + caps' <- forM caps $ \cap -> case cap of + TApp a _ -> view _1 <$> appToCap a + o -> evalError' o "Expected capability invocation" + setenv eeSessionSig $ Just (PublicKeyText publicKey, S.fromList (V.toList caps')) + return $ tStr "Setting transaction session public-key/caps" +setsession i as = argsError' i as + continuePact :: RNativeFun LibState continuePact i as = case as of [TLitInteger step] -> diff --git a/src/Pact/Types/Command.hs b/src/Pact/Types/Command.hs index 14c62510a..35b692863 100644 --- a/src/Pact/Types/Command.hs +++ b/src/Pact/Types/Command.hs @@ -39,7 +39,7 @@ module Pact.Types.Command , PPKScheme(..) #endif , ProcessedCommand(..),_ProcSucc,_ProcFail - , Payload(..),pMeta,pNonce,pPayload,pSigners,pNetworkId + , Payload(..),pMeta,pNonce,pPayload,pSigners,pSessionSigner,pNetworkId , ParsedCode(..),pcCode,pcExps , Signer(..),siScheme, siPubKey, siAddress, siCapList , UserSig(..),usSig @@ -136,7 +136,7 @@ mkCommand -> IO (Command ByteString) mkCommand creds meta nonce nid rpc = mkCommand' creds encodedPayload where encodedPayload = BSL.toStrict $ A.encode payload - payload = Payload rpc nonce meta (keyPairsToSigners creds) nid + payload = Payload rpc nonce meta (keyPairsToSigners creds) Nothing nid keyPairToSigner :: SomeKeyPair -> [SigCapability] -> Signer keyPairToSigner cred caps = Signer scheme pub addr caps @@ -171,7 +171,7 @@ mkUnsignedCommand -> IO (Command ByteString) mkUnsignedCommand signers meta nonce nid rpc = mkCommand' [] encodedPayload where encodedPayload = BSL.toStrict $ A.encode payload - payload = Payload rpc nonce meta signers nid + payload = Payload rpc nonce meta signers Nothing nid signHash :: TypedHash h -> SomeKeyPair -> IO UserSig signHash hsh cred = UserSig . toB16Text <$> sign cred (toUntypedHash hsh) @@ -275,6 +275,7 @@ data Payload m c = Payload , _pNonce :: !Text , _pMeta :: !m , _pSigners :: ![Signer] + , _pSessionSigner :: Maybe Signer , _pNetworkId :: !(Maybe NetworkId) } deriving (Show, Eq, Generic, Functor, Foldable, Traversable) instance (NFData a,NFData m) => NFData (Payload m a) diff --git a/tests/GoldenSpec.hs b/tests/GoldenSpec.hs index a108af694..2d142a9be 100644 --- a/tests/GoldenSpec.hs +++ b/tests/GoldenSpec.hs @@ -153,7 +153,7 @@ doCRTest' ec tn code = beforeAllWith initRes $ initRes s = do let dbEnv = PactDbEnv (view (rEnv . eePactDb) s) (view (rEnv . eePactDbVar) s) cmd = Command payload [] initialHash - payload = Payload exec "" pubMeta [] Nothing + payload = Payload exec "" pubMeta [] Nothing Nothing pubMeta = def parsedCode = either error id $ parsePact code exec = Exec $ ExecMsg parsedCode Null diff --git a/tests/SchemeSpec.hs b/tests/SchemeSpec.hs index d8b0551f7..e753db05b 100644 --- a/tests/SchemeSpec.hs +++ b/tests/SchemeSpec.hs @@ -82,7 +82,7 @@ toSigners kps = return $ map makeSigner kps toExecPayload :: [Signer] -> Text -> ByteString toExecPayload signers t = BSL.toStrict $ A.encode payload where - payload = Payload (Exec (ExecMsg t Null)) "nonce" () signers Nothing + payload = Payload (Exec (ExecMsg t Null)) "nonce" () signers Nothing Nothing shouldBeProcFail :: ProcessedCommand () ParsedCode -> Expectation From bfe2ad1a45d4a9ef6817b03577c22a2aef1c876d Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Wed, 29 Mar 2023 17:29:11 -0700 Subject: [PATCH 08/26] Add enforce-session to gas tests and gas golden --- golden/gas-model/golden | 2 ++ src-ghc/Pact/GasModel/GasTests.hs | 14 +++++++++++++- src/Pact/Gas/Table.hs | 1 + 3 files changed, 16 insertions(+), 1 deletion(-) diff --git a/golden/gas-model/golden b/golden/gas-model/golden index c0e7e5f2b..7eab4d54f 100644 --- a/golden/gas-model/golden +++ b/golden/gas-model/golden @@ -914,6 +914,8 @@ (diff-time (time "2016-07-22T12:00:00Z") (time "2018-07-22T12:00:00Z")) - 12 +- - (enforce-session 'some-loaded-keyset) + - 8 - - (make-list longNumber true) - 1026 - - (make-list medNumber true) diff --git a/src-ghc/Pact/GasModel/GasTests.hs b/src-ghc/Pact/GasModel/GasTests.hs index 0f2d0ce89..4f74c8237 100644 --- a/src-ghc/Pact/GasModel/GasTests.hs +++ b/src-ghc/Pact/GasModel/GasTests.hs @@ -16,7 +16,7 @@ import Data.Aeson (toJSON, ToJSON(..)) import Data.Bool (bool) import Data.Default (def) import Data.List (foldl') -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import NeatInterpolation (text) @@ -171,6 +171,7 @@ allTests = HM.fromList -- Keyset native functions , ("define-keyset", defineKeysetTests) , ("enforce-keyset", enforceKeysetTests) + , ("enforce-session", enforceSessionTests) , ("keys-2", keys2Tests) , ("keys-all", keysAllTests) , ("keys-any", keysAnyTests) @@ -546,6 +547,17 @@ enforceKeysetTests = tests updateEnvMsgSig [enforceKeysetExpr] +enforceSessionTests :: NativeDefName -> GasUnitTests +enforceSessionTests = tests + where + enforceSessionExpr = defPactExpression [text| (enforce-session '$sampleLoadedKeysetName) |] + updateEnvMsgSession = setEnv (set eeSessionSig (listToMaybe $ F.toList samplePubKeysWithCaps)) + + tests = + createGasUnitTests + updateEnvMsgSession + updateEnvMsgSession + [enforceSessionExpr] readKeysetTests :: NativeDefName -> GasUnitTests readKeysetTests = tests diff --git a/src/Pact/Gas/Table.hs b/src/Pact/Gas/Table.hs index 5d98f9081..4507d135b 100644 --- a/src/Pact/Gas/Table.hs +++ b/src/Pact/Gas/Table.hs @@ -111,6 +111,7 @@ defaultGasTable = ,("enforce", 1) ,("enforce-guard", 8) ,("enforce-keyset", 8) + ,("enforce-session", 8) ,("enforce-one", 6) ,("enforce-pact-version", 1) ,("enumerate", 1) From 6fb10daef99dd8a22844fd28761cd46010f02518 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Wed, 29 Mar 2023 21:40:23 -0700 Subject: [PATCH 09/26] Update hashed payloads in continuation tests --- tests/cont-scripts/fail-both-price-down-01-cont-badcaps.yaml | 2 +- tests/cont-scripts/fail-both-price-up-01-cont.yaml | 2 +- tests/cont-scripts/fail-cred-finish-01-cont.yaml | 2 +- tests/cont-scripts/fail-deb-cancel-01-rollback.yaml | 2 +- tests/cont-scripts/fail-deb-finish-01-cont.yaml | 2 +- tests/cont-scripts/pass-both-price-down-01-cont.yaml | 2 +- tests/cont-scripts/pass-cred-cancel-02-rollback.yaml | 2 +- tests/cont-scripts/pass-deb-cancel-02-rollback.yaml | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/cont-scripts/fail-both-price-down-01-cont-badcaps.yaml b/tests/cont-scripts/fail-both-price-down-01-cont-badcaps.yaml index 9171afe8e..8d677a260 100644 --- a/tests/cont-scripts/fail-both-price-down-01-cont-badcaps.yaml +++ b/tests/cont-scripts/fail-both-price-down-01-cont-badcaps.yaml @@ -1,7 +1,7 @@ # Both debtor and creditor can finish together if price remains the same # or negotiated down BUT bad caps ruin the day. type: "cont" -pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" +pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" step: 1 rollback: False data: {final-price: 1.75} diff --git a/tests/cont-scripts/fail-both-price-up-01-cont.yaml b/tests/cont-scripts/fail-both-price-up-01-cont.yaml index e4b1e3c7a..8dee5aef6 100644 --- a/tests/cont-scripts/fail-both-price-up-01-cont.yaml +++ b/tests/cont-scripts/fail-both-price-up-01-cont.yaml @@ -1,6 +1,6 @@ # Both debtor and creditor can finish together, but cannot negotiate price up type: "cont" -pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" +pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" step: 1 rollback: False data: {final-price: 12.0} diff --git a/tests/cont-scripts/fail-cred-finish-01-cont.yaml b/tests/cont-scripts/fail-cred-finish-01-cont.yaml index 7e95a7b78..de026549a 100644 --- a/tests/cont-scripts/fail-cred-finish-01-cont.yaml +++ b/tests/cont-scripts/fail-cred-finish-01-cont.yaml @@ -1,6 +1,6 @@ # Creditor (Bob) cannot finish alone type: "cont" -pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" +pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" step: 1 rollback: False keyPairs: diff --git a/tests/cont-scripts/fail-deb-cancel-01-rollback.yaml b/tests/cont-scripts/fail-deb-cancel-01-rollback.yaml index 5bb8116f0..33b40bbf3 100644 --- a/tests/cont-scripts/fail-deb-cancel-01-rollback.yaml +++ b/tests/cont-scripts/fail-deb-cancel-01-rollback.yaml @@ -1,6 +1,6 @@ # Debtor (Alice) cannot cancel pre-timeout type: "cont" -pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" +pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" step: 0 rollback: True keyPairs: diff --git a/tests/cont-scripts/fail-deb-finish-01-cont.yaml b/tests/cont-scripts/fail-deb-finish-01-cont.yaml index 65d8348ea..3e16a66a3 100644 --- a/tests/cont-scripts/fail-deb-finish-01-cont.yaml +++ b/tests/cont-scripts/fail-deb-finish-01-cont.yaml @@ -1,6 +1,6 @@ # Debtor (Alice) cannot finish alone type: "cont" -pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" +pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" step: 1 rollback: False keyPairs: diff --git a/tests/cont-scripts/pass-both-price-down-01-cont.yaml b/tests/cont-scripts/pass-both-price-down-01-cont.yaml index 1c9e88c44..a94ed9a2b 100644 --- a/tests/cont-scripts/pass-both-price-down-01-cont.yaml +++ b/tests/cont-scripts/pass-both-price-down-01-cont.yaml @@ -1,7 +1,7 @@ # Both debtor and creditor can finish together if price remains the same # or negotiated down. type: "cont" -pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" +pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" step: 1 rollback: False data: {final-price: 1.75} diff --git a/tests/cont-scripts/pass-cred-cancel-02-rollback.yaml b/tests/cont-scripts/pass-cred-cancel-02-rollback.yaml index 3270e4d6d..c47eae13c 100644 --- a/tests/cont-scripts/pass-cred-cancel-02-rollback.yaml +++ b/tests/cont-scripts/pass-cred-cancel-02-rollback.yaml @@ -1,6 +1,6 @@ # Creditor (Bob) can cancel anytime type: "cont" -pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" +pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" step: 0 rollback: True keyPairs: diff --git a/tests/cont-scripts/pass-deb-cancel-02-rollback.yaml b/tests/cont-scripts/pass-deb-cancel-02-rollback.yaml index c1767a75d..28431da4f 100644 --- a/tests/cont-scripts/pass-deb-cancel-02-rollback.yaml +++ b/tests/cont-scripts/pass-deb-cancel-02-rollback.yaml @@ -1,6 +1,6 @@ # Debtor (Alice) can cancel after timeout type: "cont" -pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" +pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" step: 0 rollback: True keyPairs: From 6b228f61acbe045c7b56b5736aa6226ea6c68876 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Mon, 3 Apr 2023 15:20:36 -0700 Subject: [PATCH 10/26] Remove sessionSigner from the pact payload --- src-ghc/Pact/Bench.hs | 13 ++++++------- src-ghc/Pact/GasModel/Types.hs | 2 +- src-ghc/Pact/Interpreter.hs | 10 +++++----- src-ghc/Pact/Server/PactService.hs | 6 +++--- 4 files changed, 15 insertions(+), 16 deletions(-) diff --git a/src-ghc/Pact/Bench.hs b/src-ghc/Pact/Bench.hs index dca3f3069..4002f72ac 100644 --- a/src-ghc/Pact/Bench.hs +++ b/src-ghc/Pact/Bench.hs @@ -156,9 +156,8 @@ loadBenchModule db = do Nothing pactInitialHash [Signer Nothing pk Nothing []] - Nothing let ec = ExecutionConfig $ S.fromList [FlagDisablePact44] - e <- setupEvalEnv db entity Transactional md initRefStore + e <- setupEvalEnv db entity Transactional md Nothing initRefStore freeGasEnv permissiveNamespacePolicy noSPVSupport def ec (r :: Either SomeException EvalResult) <- try $ evalExec defaultInterpreter e pc void $ eitherDie "loadBenchModule (load)" $ fmapL show r @@ -184,10 +183,10 @@ benchNFIO bname = bench bname . nfIO runPactExec :: Advice -> String -> [Signer] -> Value -> Maybe (ModuleData Ref) -> PactDbEnv e -> ParsedCode -> IO [PactValue] runPactExec pt msg ss cdata benchMod dbEnv pc = do - let md = MsgData cdata Nothing pactInitialHash ss Nothing + let md = MsgData cdata Nothing pactInitialHash ss ec = ExecutionConfig $ S.fromList [FlagDisablePact44] - e <- fmap (set eeAdvice pt) $ setupEvalEnv dbEnv entity Transactional md - initRefStore prodGasEnv permissiveNamespacePolicy noSPVSupport def ec + e <- fmap (set eeAdvice pt) $ setupEvalEnv dbEnv entity Transactional md Nothing + initRefStore prodGasEnv permissiveNamespacePolicy noSPVSupport def ec let s = perfInterpreter pt $ defaultInterpreterState $ maybe id (const . initStateModules . HM.singleton (ModuleName "bench" Nothing)) benchMod (r :: Either SomeException EvalResult) <- try $! evalExec s e pc @@ -196,9 +195,9 @@ runPactExec pt msg ss cdata benchMod dbEnv pc = do execPure :: Advice -> PactDbEnv e -> (String,[Term Name]) -> IO [Term Name] execPure pt dbEnv (n,ts) = do - let md = MsgData Null Nothing pactInitialHash [] Nothing + let md = MsgData Null Nothing pactInitialHash [] ec = ExecutionConfig $ S.fromList [FlagDisablePact44] - env <- fmap (set eeAdvice pt) $ setupEvalEnv dbEnv entity Local md + env <- fmap (set eeAdvice pt) $ setupEvalEnv dbEnv entity Local md Nothing initRefStore prodGasEnv permissiveNamespacePolicy noSPVSupport def ec o <- try $ runEval def env $ mapM eval ts case o of diff --git a/src-ghc/Pact/GasModel/Types.hs b/src-ghc/Pact/GasModel/Types.hs index 745f5443b..5179c8095 100644 --- a/src-ghc/Pact/GasModel/Types.hs +++ b/src-ghc/Pact/GasModel/Types.hs @@ -237,7 +237,7 @@ getLoadedState code = do defEvalEnv :: PactDbEnv e -> IO (EvalEnv e) defEvalEnv db = do - setupEvalEnv db entity Transactional (initMsgData pactInitialHash) + setupEvalEnv db entity Transactional (initMsgData pactInitialHash) Nothing initRefStore prodGasModel permissiveNamespacePolicy noSPVSupport def noPact44EC where entity = Just $ EntityName "entity" prodGasModel = GasEnv 10000000 0.01 $ tableGasModel defaultGasConfig diff --git a/src-ghc/Pact/Interpreter.hs b/src-ghc/Pact/Interpreter.hs index 6fbb45250..f6b963d39 100644 --- a/src-ghc/Pact/Interpreter.hs +++ b/src-ghc/Pact/Interpreter.hs @@ -78,13 +78,12 @@ data MsgData = MsgData { mdData :: !Value, mdStep :: !(Maybe PactStep), mdHash :: !Hash, - mdSigners :: [Signer], - mdSessionSigner :: Maybe Signer + mdSigners :: [Signer] } initMsgData :: Hash -> MsgData -initMsgData h = MsgData Null def h def def +initMsgData h = MsgData Null def h def -- | Describes either a ContMsg or ExecMsg. -- ContMsg is represented as a 'Maybe PactExec' @@ -163,6 +162,7 @@ setupEvalEnv -> Maybe EntityName -> ExecutionMode -> MsgData + -> Maybe Signer -> RefStore -> GasEnv -> NamespacePolicy @@ -170,13 +170,13 @@ setupEvalEnv -> PublicData -> ExecutionConfig -> IO (EvalEnv e) -setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do +setupEvalEnv dbEnv ent mode msgData sessionSigner refStore gasEnv np spv pd ec = do gasRef <- newIORef 0 warnRef <- newIORef mempty pure EvalEnv { _eeRefStore = refStore , _eeMsgSigs = mkMsgSigs $ mdSigners msgData - , _eeSessionSig = toPair <$> mdSessionSigner msgData + , _eeSessionSig = toPair <$> sessionSigner , _eeMsgBody = mdData msgData , _eeMode = mode , _eeEntity = ent diff --git a/src-ghc/Pact/Server/PactService.hs b/src-ghc/Pact/Server/PactService.hs index 1892fcd4e..6c2a66dc5 100644 --- a/src-ghc/Pact/Server/PactService.hs +++ b/src-ghc/Pact/Server/PactService.hs @@ -151,8 +151,8 @@ applyExec rk hsh signers sessionSigner (ExecMsg parsedCode edata) = do when (null (_pcExps parsedCode)) $ throwCmdEx "No expressions found" evalEnv <- liftIO $ setupEvalEnv _ceDbEnv _ceEntity _ceMode - (MsgData edata Nothing (toUntypedHash hsh) signers sessionSigner) - initRefStore _ceGasEnv permissiveNamespacePolicy + (MsgData edata Nothing (toUntypedHash hsh) signers) + sessionSigner initRefStore _ceGasEnv permissiveNamespacePolicy _ceSPVSupport _cePublicData _ceExecutionConfig EvalResult{..} <- liftIO $ evalExec defaultInterpreter evalEnv parsedCode mapM_ (\p -> liftIO $ logLog _ceLogger "DEBUG" $ "applyExec: new pact added: " ++ show p) _erExec @@ -164,7 +164,7 @@ applyContinuation rk hsh signers sessionSigner cm = do CommandEnv{..} <- ask -- Setup environment and get result evalEnv <- liftIO $ setupEvalEnv _ceDbEnv _ceEntity _ceMode - (MsgData (_cmData cm) Nothing (toUntypedHash hsh) signers sessionSigner) initRefStore + (MsgData (_cmData cm) Nothing (toUntypedHash hsh) signers) sessionSigner initRefStore _ceGasEnv permissiveNamespacePolicy _ceSPVSupport _cePublicData _ceExecutionConfig EvalResult{..} <- liftIO $ evalContinuation defaultInterpreter evalEnv cm return $ resultSuccess _erTxId rk _erGas (last _erOutput) _erExec _erLogs _erEvents From bb25cd3176ec7c28254781f07d9362ed13d7e5ca Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Tue, 4 Apr 2023 15:00:49 -0700 Subject: [PATCH 11/26] wip move sessionSigner into CommandEnv --- src-ghc/Pact/Bench.hs | 2 +- src-ghc/Pact/Server/PactService.hs | 23 +++++++++++++---------- src-ghc/Pact/Types/Server.hs | 3 ++- src/Pact/Types/Command.hs | 11 +++++------ 4 files changed, 21 insertions(+), 18 deletions(-) diff --git a/src-ghc/Pact/Bench.hs b/src-ghc/Pact/Bench.hs index 4002f72ac..5e454ec21 100644 --- a/src-ghc/Pact/Bench.hs +++ b/src-ghc/Pact/Bench.hs @@ -236,7 +236,7 @@ mkBenchCmd :: [SomeKeyPairCaps] -> (String, Text) -> IO (String, Command ByteStr mkBenchCmd kps (str, t) = do cmd <- mkCommand' kps $ toStrict . encode - $ Payload payload "nonce" () ss Nothing Nothing + $ Payload payload "nonce" () ss Nothing return (str, cmd) where payload = Exec $ ExecMsg t Null diff --git a/src-ghc/Pact/Server/PactService.hs b/src-ghc/Pact/Server/PactService.hs index 6c2a66dc5..387bab666 100644 --- a/src-ghc/Pact/Server/PactService.hs +++ b/src-ghc/Pact/Server/PactService.hs @@ -58,15 +58,15 @@ initPactService CommandConfig {..} loggers spv = do klog "Creating Pact Schema" initSchema p return CommandExecInterface - { _ceiApplyCmd = \eMode cmd -> + { _ceiApplyCmd = \eMode sessionSigner cmd -> applyCmd logger _ccEntity p gasModel blockHeight blockTime prevBlockHash spv _ccExecutionConfig - eMode cmd (verifyCommand cmd) - , _ceiApplyPPCmd = + eMode sessionSigner cmd (verifyCommand cmd) + , _ceiApplyPPCmd = \eMode sessionSigner cmd -> applyCmd logger _ccEntity p gasModel blockHeight blockTime prevBlockHash - spv _ccExecutionConfig + spv _ccExecutionConfig eMode sessionSigner cmd } case _ccSqlite of Nothing -> do @@ -87,15 +87,16 @@ applyCmd :: Logger -> SPVSupport -> ExecutionConfig -> ExecutionMode -> + Maybe Signer -> Command a -> ProcessedCommand PublicMeta ParsedCode -> IO (CommandResult Hash) -applyCmd _ _ _ _ _ _ _ _ _ _ cmd (ProcFail s) = +applyCmd _ _ _ _ _ _ _ _ _ _ _ cmd (ProcFail s) = return $ resultFailure Nothing (cmdToRequestKey cmd) (PactError TxFailure def def . viaShow $ s) -applyCmd logger conf dbv gasModel bh _ pbh spv exConfig exMode _ (ProcSucc cmd) = do +applyCmd logger conf dbv gasModel bh _ pbh spv exConfig exMode sessionSigner _ (ProcSucc cmd) = do blocktime <- (((*) 1000000) <$> systemSeconds <$> getSystemTime) let payload = _cmdPayload cmd @@ -105,7 +106,7 @@ applyCmd logger conf dbv gasModel bh _ pbh spv exConfig exMode _ (ProcSucc cmd) nid = _pNetworkId payload res <- catchesPactError $ runCommand - (CommandEnv conf exMode dbv logger gasEnv pd spv nid exConfig) + (CommandEnv conf exMode dbv logger gasEnv pd spv nid exConfig sessionSigner) (runPayload cmd) case res of Right cr -> do @@ -140,9 +141,11 @@ fullToHashLogCr full = (pactHash . BSL.toStrict . encode) full runPayload :: Command (Payload PublicMeta ParsedCode) -> CommandM p (CommandResult Hash) -runPayload c@Command{..} = case (_pPayload _cmdPayload) of - Exec pm -> applyExec (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) (_pSessionSigner _cmdPayload) pm - Continuation ym -> applyContinuation (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) (_pSessionSigner _cmdPayload) ym +runPayload c@Command{..} = do + sessionSigner <- asks _ceSessionSigner + case (_pPayload _cmdPayload) of + Exec pm -> applyExec (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) sessionSigner pm + Continuation ym -> applyContinuation (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) sessionSigner ym applyExec :: RequestKey -> PactHash -> [Signer] -> Maybe Signer -> ExecMsg ParsedCode -> CommandM p (CommandResult Hash) diff --git a/src-ghc/Pact/Types/Server.hs b/src-ghc/Pact/Types/Server.hs index 9b9106d08..a7aa1cce9 100644 --- a/src-ghc/Pact/Types/Server.hs +++ b/src-ghc/Pact/Types/Server.hs @@ -27,7 +27,7 @@ module Pact.Types.Server , ccExecutionConfig , CommandEnv(..), ceEntity, ceMode, ceDbEnv, ceLogger , cePublicData, ceGasEnv, ceSPVSupport, ceNetworkId - , ceExecutionConfig + , ceExecutionConfig, ceSessionSigner , CommandM, runCommand, throwCmdEx , History(..) , ExistenceResult(..) @@ -93,6 +93,7 @@ data CommandEnv p = CommandEnv { , _ceSPVSupport :: SPVSupport , _ceNetworkId :: Maybe NetworkId , _ceExecutionConfig :: ExecutionConfig + , _ceSessionSigner :: Maybe Signer } $(makeLenses ''CommandEnv) diff --git a/src/Pact/Types/Command.hs b/src/Pact/Types/Command.hs index 35b692863..696b45a85 100644 --- a/src/Pact/Types/Command.hs +++ b/src/Pact/Types/Command.hs @@ -39,7 +39,7 @@ module Pact.Types.Command , PPKScheme(..) #endif , ProcessedCommand(..),_ProcSucc,_ProcFail - , Payload(..),pMeta,pNonce,pPayload,pSigners,pSessionSigner,pNetworkId + , Payload(..),pMeta,pNonce,pPayload,pSigners,pNetworkId , ParsedCode(..),pcCode,pcExps , Signer(..),siScheme, siPubKey, siAddress, siCapList , UserSig(..),usSig @@ -136,7 +136,7 @@ mkCommand -> IO (Command ByteString) mkCommand creds meta nonce nid rpc = mkCommand' creds encodedPayload where encodedPayload = BSL.toStrict $ A.encode payload - payload = Payload rpc nonce meta (keyPairsToSigners creds) Nothing nid + payload = Payload rpc nonce meta (keyPairsToSigners creds) nid keyPairToSigner :: SomeKeyPair -> [SigCapability] -> Signer keyPairToSigner cred caps = Signer scheme pub addr caps @@ -171,7 +171,7 @@ mkUnsignedCommand -> IO (Command ByteString) mkUnsignedCommand signers meta nonce nid rpc = mkCommand' [] encodedPayload where encodedPayload = BSL.toStrict $ A.encode payload - payload = Payload rpc nonce meta signers Nothing nid + payload = Payload rpc nonce meta signers nid signHash :: TypedHash h -> SomeKeyPair -> IO UserSig signHash hsh cred = UserSig . toB16Text <$> sign cred (toUntypedHash hsh) @@ -275,7 +275,6 @@ data Payload m c = Payload , _pNonce :: !Text , _pMeta :: !m , _pSigners :: ![Signer] - , _pSessionSigner :: Maybe Signer , _pNetworkId :: !(Maybe NetworkId) } deriving (Show, Eq, Generic, Functor, Foldable, Traversable) instance (NFData a,NFData m) => NFData (Payload m a) @@ -364,8 +363,8 @@ cmdToRequestKey Command {..} = RequestKey (toUntypedHash _cmdHash) -type ApplyCmd l = ExecutionMode -> Command ByteString -> IO (CommandResult l) -type ApplyPPCmd m a l = ExecutionMode -> Command ByteString -> ProcessedCommand m a -> IO (CommandResult l) +type ApplyCmd l = ExecutionMode -> Maybe Signer -> Command ByteString -> IO (CommandResult l) +type ApplyPPCmd m a l = ExecutionMode -> Maybe Signer -> Command ByteString -> ProcessedCommand m a -> IO (CommandResult l) data CommandExecInterface m a l = CommandExecInterface { _ceiApplyCmd :: ApplyCmd l From 452198e02a59456f8aef5c8d1a72b9124d328790 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Wed, 5 Apr 2023 08:30:43 -0700 Subject: [PATCH 12/26] Pass sessionPubkey into the environment through the Command --- src-ghc/Pact/ApiReq.hs | 39 +++++++++++++++----- src-ghc/Pact/Bench.hs | 2 +- src-ghc/Pact/Interpreter.hs | 6 ++-- src-ghc/Pact/Server/History/Persistence.hs | 1 + src-ghc/Pact/Server/History/Service.hs | 2 +- src-ghc/Pact/Server/PactService.hs | 28 +++++++-------- src-ghc/Pact/Types/Server.hs | 3 +- src/Pact/Eval.hs | 13 ++++--- src/Pact/Types/Command.hs | 42 ++++++++++++---------- src/Pact/Types/SigData.hs | 3 +- 10 files changed, 82 insertions(+), 57 deletions(-) diff --git a/src-ghc/Pact/ApiReq.hs b/src-ghc/Pact/ApiReq.hs index 143ef8f04..609425c30 100644 --- a/src-ghc/Pact/ApiReq.hs +++ b/src-ghc/Pact/ApiReq.hs @@ -72,6 +72,8 @@ import Pact.Types.Runtime import Pact.Types.SigData import Pact.Types.SPV +-- import Debug.Trace (trace) + -- | For fully-signed commands data ApiKeyPair = ApiKeyPair { _akpSecret :: PrivateKeyBS, @@ -141,7 +143,8 @@ data ApiReq = ApiReq { _ylSigners :: Maybe [ApiSigner], _ylNonce :: Maybe Text, _ylPublicMeta :: Maybe ApiPublicMeta, - _ylNetworkId :: Maybe NetworkId + _ylNetworkId :: Maybe NetworkId, + _ylSessionPubkey :: Maybe PublicKeyText } deriving (Eq,Show,Generic) instance ToJSON ApiReq where toJSON = lensyToJSON 3 instance FromJSON ApiReq where parseJSON = lensyParseJSON 3 @@ -400,8 +403,8 @@ mkApiReqExec unsignedReq ar@ApiReq{..} fp = do return (code,cdata) pubMeta <- mkPubMeta _ylPublicMeta cmd <- withKeypairsOrSigner unsignedReq ar - (\ks -> mkExec code cdata pubMeta ks _ylNetworkId _ylNonce) - (\ss -> mkUnsignedExec code cdata pubMeta ss _ylNetworkId _ylNonce) + (\ks -> mkExec code cdata pubMeta ks _ylNetworkId _ylNonce _ylSessionPubkey) + (\ss -> mkUnsignedExec code cdata pubMeta ss _ylNetworkId _ylNonce _ylSessionPubkey) return ((ar,code,cdata,pubMeta), cmd) mkPubMeta :: Maybe ApiPublicMeta -> IO PublicMeta @@ -441,14 +444,17 @@ mkExec -- ^ optional 'NetworkId' -> Maybe Text -- ^ optional nonce + -> Maybe PublicKeyText + -- ^ optional session pubkey -> IO (Command Text) -mkExec code mdata pubMeta kps nid ridm = do +mkExec code mdata pubMeta kps nid ridm mSessionPubkey = do rid <- mkNonce ridm cmd <- mkCommand kps pubMeta rid nid + (fmap convertKey mSessionPubkey) (Exec (ExecMsg code mdata)) return $ decodeUtf8 <$> cmd @@ -467,14 +473,17 @@ mkUnsignedExec -- ^ optional 'NetworkId' -> Maybe Text -- ^ optional nonce + -> Maybe PublicKeyText + -- ^ optional session pubkey -> IO (Command Text) -mkUnsignedExec code mdata pubMeta kps nid ridm = do +mkUnsignedExec code mdata pubMeta kps nid ridm sessionPubkey = do rid <- mkNonce ridm cmd <- mkUnsignedCommand kps pubMeta rid nid + (fmap convertKey sessionPubkey) (Exec (ExecMsg code mdata)) return $ decodeUtf8 <$> cmd @@ -505,8 +514,8 @@ mkApiReqCont unsignedReq ar@ApiReq{..} fp = do let pactId = toPactId apiPactId pubMeta <- mkPubMeta _ylPublicMeta cmd <- withKeypairsOrSigner unsignedReq ar - (\ks -> mkCont pactId step rollback cdata pubMeta ks _ylNonce _ylProof _ylNetworkId) - (\ss -> mkUnsignedCont pactId step rollback cdata pubMeta ss _ylNonce _ylProof _ylNetworkId) + (\ks -> mkCont pactId step rollback cdata pubMeta ks _ylNonce _ylProof _ylNetworkId _ylSessionPubkey) + (\ss -> mkUnsignedCont pactId step rollback cdata pubMeta ss _ylNonce _ylProof _ylNetworkId _ylSessionPubkey) return ((ar,"",cdata,pubMeta), cmd) -- | Construct a Cont request message @@ -530,14 +539,16 @@ mkCont -- ^ optional continuation proof (required for cross-chain) -> Maybe NetworkId -- ^ optional network id + -> Maybe PublicKeyText -> IO (Command Text) -mkCont txid step rollback mdata pubMeta kps ridm proof nid = do +mkCont txid step rollback mdata pubMeta kps ridm proof nid sessionPubkey = do rid <- mkNonce ridm cmd <- mkCommand kps pubMeta rid nid + (fmap convertKey sessionPubkey) (Continuation (ContMsg txid step rollback mdata proof) :: (PactRPC ContMsg)) return $ decodeUtf8 <$> cmd @@ -563,14 +574,17 @@ mkUnsignedCont -- ^ optional continuation proof (required for cross-chain) -> Maybe NetworkId -- ^ optional network id + -> Maybe PublicKeyText + -- ^ optional session public key -> IO (Command Text) -mkUnsignedCont txid step rollback mdata pubMeta kps ridm proof nid = do +mkUnsignedCont txid step rollback mdata pubMeta kps ridm proof nid sessionPubkey = do rid <- mkNonce ridm cmd <- mkUnsignedCommand kps pubMeta (pack $ show rid) nid + (convertKey <$> sessionPubkey) (Continuation (ContMsg txid step rollback mdata proof) :: (PactRPC ContMsg)) return $ decodeUtf8 <$> cmd @@ -627,5 +641,12 @@ dieAR errMsg = throwM . userError $ intercalate "\n" $ ," step: step index to continue" ," rollback: rollback/cancel flag" ," proof: platform-specific continuation proof data" + ," sessionKey: the public key representing a user with an active session" ,"Error message: " ++ errMsg ] + +-- convertKey :: PublicKeyBS -> PublicKeyText +-- convertKey (PubBS pkey) = trace (show pkey) $ PublicKeyText (decodeUtf8 pkey) + +convertKey :: a -> a +convertKey = id diff --git a/src-ghc/Pact/Bench.hs b/src-ghc/Pact/Bench.hs index 5e454ec21..9ac78c8f6 100644 --- a/src-ghc/Pact/Bench.hs +++ b/src-ghc/Pact/Bench.hs @@ -234,7 +234,7 @@ benchReadValue _ (TxTable _t) _k = rcp Nothing mkBenchCmd :: [SomeKeyPairCaps] -> (String, Text) -> IO (String, Command ByteString) mkBenchCmd kps (str, t) = do - cmd <- mkCommand' kps + cmd <- mkCommand' kps Nothing $ toStrict . encode $ Payload payload "nonce" () ss Nothing return (str, cmd) diff --git a/src-ghc/Pact/Interpreter.hs b/src-ghc/Pact/Interpreter.hs index f6b963d39..a394b428a 100644 --- a/src-ghc/Pact/Interpreter.hs +++ b/src-ghc/Pact/Interpreter.hs @@ -162,7 +162,7 @@ setupEvalEnv -> Maybe EntityName -> ExecutionMode -> MsgData - -> Maybe Signer + -> Maybe PublicKeyText -> RefStore -> GasEnv -> NamespacePolicy @@ -170,13 +170,13 @@ setupEvalEnv -> PublicData -> ExecutionConfig -> IO (EvalEnv e) -setupEvalEnv dbEnv ent mode msgData sessionSigner refStore gasEnv np spv pd ec = do +setupEvalEnv dbEnv ent mode msgData sessionPubkey refStore gasEnv np spv pd ec = do gasRef <- newIORef 0 warnRef <- newIORef mempty pure EvalEnv { _eeRefStore = refStore , _eeMsgSigs = mkMsgSigs $ mdSigners msgData - , _eeSessionSig = toPair <$> sessionSigner + , _eeSessionSig = fmap (, S.empty) sessionPubkey , _eeMsgBody = mdData msgData , _eeMode = mode , _eeEntity = ent diff --git a/src-ghc/Pact/Server/History/Persistence.hs b/src-ghc/Pact/Server/History/Persistence.hs index 8c6560156..4a00e9f8d 100644 --- a/src-ghc/Pact/Server/History/Persistence.hs +++ b/src-ghc/Pact/Server/History/Persistence.hs @@ -160,6 +160,7 @@ selectAllCommands e = do let rowToCmd [SText (Utf8 hash'),SText (Utf8 cmd'),SText (Utf8 userSigs')] = Command { _cmdPayload = cmd' , _cmdSigs = userSigsFromField userSigs' + , _cmdSessionPubKey = Nothing , _cmdHash = fromUntypedHash $ hashFromField hash'} rowToCmd err = error $ "selectAllCommands: unexpected result schema: " ++ show err fmap rowToCmd <$> qrys_ (_qrySelectAllCmds e) [RText,RText,RText] diff --git a/src-ghc/Pact/Server/History/Service.hs b/src-ghc/Pact/Server/History/Service.hs index b77196ca4..db88cdab3 100644 --- a/src-ghc/Pact/Server/History/Service.hs +++ b/src-ghc/Pact/Server/History/Service.hs @@ -245,7 +245,7 @@ _testHistoryDB = do _go :: HistoryService () _go = do - addNewKeys [Command "" [] initialHash] + addNewKeys [Command "" [] Nothing initialHash] let rq = RequestKey pactInitialHash res = PactResult $ Left $ PactError TxFailure def def . viaShow $ ("some error message" :: String) updateExistingKeys (HashMap.fromList [(rq, CommandResult rq Nothing res (Gas 0) Nothing Nothing Nothing [])]) diff --git a/src-ghc/Pact/Server/PactService.hs b/src-ghc/Pact/Server/PactService.hs index 387bab666..4d6cb02af 100644 --- a/src-ghc/Pact/Server/PactService.hs +++ b/src-ghc/Pact/Server/PactService.hs @@ -58,15 +58,15 @@ initPactService CommandConfig {..} loggers spv = do klog "Creating Pact Schema" initSchema p return CommandExecInterface - { _ceiApplyCmd = \eMode sessionSigner cmd -> + { _ceiApplyCmd = \eMode cmd -> applyCmd logger _ccEntity p gasModel blockHeight blockTime prevBlockHash spv _ccExecutionConfig - eMode sessionSigner cmd (verifyCommand cmd) - , _ceiApplyPPCmd = \eMode sessionSigner cmd -> + eMode cmd (verifyCommand cmd) + , _ceiApplyPPCmd = \eMode cmd -> applyCmd logger _ccEntity p gasModel blockHeight blockTime prevBlockHash - spv _ccExecutionConfig eMode sessionSigner cmd + spv _ccExecutionConfig eMode cmd } case _ccSqlite of Nothing -> do @@ -87,16 +87,15 @@ applyCmd :: Logger -> SPVSupport -> ExecutionConfig -> ExecutionMode -> - Maybe Signer -> Command a -> ProcessedCommand PublicMeta ParsedCode -> IO (CommandResult Hash) -applyCmd _ _ _ _ _ _ _ _ _ _ _ cmd (ProcFail s) = +applyCmd _ _ _ _ _ _ _ _ _ _ cmd (ProcFail s) = return $ resultFailure Nothing (cmdToRequestKey cmd) (PactError TxFailure def def . viaShow $ s) -applyCmd logger conf dbv gasModel bh _ pbh spv exConfig exMode sessionSigner _ (ProcSucc cmd) = do +applyCmd logger conf dbv gasModel bh _ pbh spv exConfig exMode _ (ProcSucc cmd) = do blocktime <- (((*) 1000000) <$> systemSeconds <$> getSystemTime) let payload = _cmdPayload cmd @@ -106,7 +105,7 @@ applyCmd logger conf dbv gasModel bh _ pbh spv exConfig exMode sessionSigner _ ( nid = _pNetworkId payload res <- catchesPactError $ runCommand - (CommandEnv conf exMode dbv logger gasEnv pd spv nid exConfig sessionSigner) + (CommandEnv conf exMode dbv logger gasEnv pd spv nid exConfig) (runPayload cmd) case res of Right cr -> do @@ -142,27 +141,26 @@ fullToHashLogCr full = (pactHash . BSL.toStrict . encode) full runPayload :: Command (Payload PublicMeta ParsedCode) -> CommandM p (CommandResult Hash) runPayload c@Command{..} = do - sessionSigner <- asks _ceSessionSigner case (_pPayload _cmdPayload) of - Exec pm -> applyExec (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) sessionSigner pm - Continuation ym -> applyContinuation (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) sessionSigner ym + Exec pm -> applyExec (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) _cmdSessionPubKey pm + Continuation ym -> applyContinuation (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) _cmdSessionPubKey ym -applyExec :: RequestKey -> PactHash -> [Signer] -> Maybe Signer -> ExecMsg ParsedCode -> CommandM p (CommandResult Hash) -applyExec rk hsh signers sessionSigner (ExecMsg parsedCode edata) = do +applyExec :: RequestKey -> PactHash -> [Signer] -> Maybe PublicKeyText -> ExecMsg ParsedCode -> CommandM p (CommandResult Hash) +applyExec rk hsh signers sessionPubkey (ExecMsg parsedCode edata) = do CommandEnv {..} <- ask when (null (_pcExps parsedCode)) $ throwCmdEx "No expressions found" evalEnv <- liftIO $ setupEvalEnv _ceDbEnv _ceEntity _ceMode (MsgData edata Nothing (toUntypedHash hsh) signers) - sessionSigner initRefStore _ceGasEnv permissiveNamespacePolicy + sessionPubkey initRefStore _ceGasEnv permissiveNamespacePolicy _ceSPVSupport _cePublicData _ceExecutionConfig EvalResult{..} <- liftIO $ evalExec defaultInterpreter evalEnv parsedCode mapM_ (\p -> liftIO $ logLog _ceLogger "DEBUG" $ "applyExec: new pact added: " ++ show p) _erExec return $ resultSuccess _erTxId rk _erGas (last _erOutput) _erExec _erLogs _erEvents -applyContinuation :: RequestKey -> PactHash -> [Signer] -> Maybe Signer -> ContMsg -> CommandM p (CommandResult Hash) +applyContinuation :: RequestKey -> PactHash -> [Signer] -> Maybe PublicKeyText -> ContMsg -> CommandM p (CommandResult Hash) applyContinuation rk hsh signers sessionSigner cm = do CommandEnv{..} <- ask -- Setup environment and get result diff --git a/src-ghc/Pact/Types/Server.hs b/src-ghc/Pact/Types/Server.hs index a7aa1cce9..9b9106d08 100644 --- a/src-ghc/Pact/Types/Server.hs +++ b/src-ghc/Pact/Types/Server.hs @@ -27,7 +27,7 @@ module Pact.Types.Server , ccExecutionConfig , CommandEnv(..), ceEntity, ceMode, ceDbEnv, ceLogger , cePublicData, ceGasEnv, ceSPVSupport, ceNetworkId - , ceExecutionConfig, ceSessionSigner + , ceExecutionConfig , CommandM, runCommand, throwCmdEx , History(..) , ExistenceResult(..) @@ -93,7 +93,6 @@ data CommandEnv p = CommandEnv { , _ceSPVSupport :: SPVSupport , _ceNetworkId :: Maybe NetworkId , _ceExecutionConfig :: ExecutionConfig - , _ceSessionSigner :: Maybe Signer } $(makeLenses ''CommandEnv) diff --git a/src/Pact/Eval.hs b/src/Pact/Eval.hs index 697a2cd69..623224ee9 100644 --- a/src/Pact/Eval.hs +++ b/src/Pact/Eval.hs @@ -150,14 +150,13 @@ enforceKeySet i ksn KeySet{..} = do -- | Enforce keyset against session key from the environment. enforceKeySetSession :: PureSysOnly e => Info -> Maybe KeySetName -> KeySet -> Eval e () enforceKeySetSession i ksn KeySet{..} = do - sigs <- maybeToMap <$> (view eeSessionSig) - sigs' <- checkSigCaps sigs - runPred (M.size sigs') + sessionPubKey <- view eeSessionSig + case sessionPubKey of + Nothing -> evalError i "enforce-session called while there is no session pubkey in the environment" + Just (publicKeyText, caps) -> do + sigs' <- checkSigCaps (M.singleton publicKeyText caps) + runPred (M.size sigs') where - maybeToMap mayKV = - maybe M.empty (\(k,v) -> if k `elem` _ksKeys - then M.singleton k v - else M.empty) mayKV failed = failTx i $ "Keyset failure " <> parens (pretty _ksPredFun) <> ": " <> maybe (pretty $ map (elide . asString) $ toList _ksKeys) pretty ksn atLeast t m = m >= t diff --git a/src/Pact/Types/Command.hs b/src/Pact/Types/Command.hs index 696b45a85..127088f8b 100644 --- a/src/Pact/Types/Command.hs +++ b/src/Pact/Types/Command.hs @@ -10,6 +10,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} @@ -24,7 +25,7 @@ -- module Pact.Types.Command - ( Command(..),cmdPayload,cmdSigs,cmdHash + ( Command(..),cmdPayload,cmdSigs,cmdSessionPubKey,cmdHash #if !defined(ghcjs_HOST_OS) , mkCommand , mkCommand' @@ -62,7 +63,7 @@ import Data.Serialize as SZ import Data.Hashable (Hashable) import Data.Aeson as A import Data.Text (Text) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, maybeToList) import GHC.Generics @@ -93,20 +94,23 @@ import Pact.Types.Scheme (PPKScheme(..), defPPKScheme) data Command a = Command { _cmdPayload :: !a , _cmdSigs :: ![UserSig] + , _cmdSessionPubKey :: Maybe PublicKeyText , _cmdHash :: !PactHash } deriving (Eq,Show,Ord,Generic,Functor,Foldable,Traversable) instance (Serialize a) => Serialize (Command a) instance (ToJSON a) => ToJSON (Command a) where - toJSON (Command payload uSigs hsh) = - object [ "cmd" .= payload - , "sigs" .= toJSON uSigs - , "hash" .= hsh - ] + toJSON (Command payload uSigs sessionPubkey hsh) = + object $ [ "cmd" .= payload + , "sigs" .= toJSON uSigs + , "hash" .= hsh + ] ++ maybeToList (("session_pubkey" .=) <$> sessionPubkey) instance (FromJSON a) => FromJSON (Command a) where - parseJSON = withObject "Command" $ \o -> - Command <$> (o .: "cmd") - <*> (o .: "sigs" >>= parseJSON) - <*> (o .: "hash") + parseJSON = withObject "Command" $ \o -> do + _cmdPayload <- o .: "cmd" + _cmdSigs <- o .: "sigs" >>= parseJSON + _cmdSessionPubKey <- (fmap . fmap) PublicKeyText $ o .:? "session_pubkey" + _cmdHash <- o .: "hash" + return $ Command { _cmdPayload, _cmdSigs, _cmdSessionPubKey, _cmdHash } {-# INLINE parseJSON #-} instance NFData a => NFData (Command a) @@ -132,9 +136,10 @@ mkCommand -> m -> Text -> Maybe NetworkId + -> Maybe PublicKeyText -> PactRPC c -> IO (Command ByteString) -mkCommand creds meta nonce nid rpc = mkCommand' creds encodedPayload +mkCommand creds meta nonce nid sessionPubkey rpc = mkCommand' creds sessionPubkey encodedPayload where encodedPayload = BSL.toStrict $ A.encode payload payload = Payload rpc nonce meta (keyPairsToSigners creds) nid @@ -153,12 +158,12 @@ keyPairsToSigners :: [SomeKeyPairCaps] -> [Signer] keyPairsToSigners creds = map (uncurry keyPairToSigner) creds -mkCommand' :: [(SomeKeyPair,a)] -> ByteString -> IO (Command ByteString) -mkCommand' creds env = do +mkCommand' :: [(SomeKeyPair,a)] -> Maybe PublicKeyText -> ByteString -> IO (Command ByteString) +mkCommand' creds sessionPubkey env = do let hsh = hash env -- hash associated with a Command, aka a Command's Request Key toUserSig (cred,_) = signHash hsh cred sigs <- traverse toUserSig creds - return $ Command env sigs hsh + return $ Command env sigs sessionPubkey hsh mkUnsignedCommand :: ToJSON m @@ -167,9 +172,10 @@ mkUnsignedCommand -> m -> Text -> Maybe NetworkId + -> Maybe PublicKeyText -> PactRPC c -> IO (Command ByteString) -mkUnsignedCommand signers meta nonce nid rpc = mkCommand' [] encodedPayload +mkUnsignedCommand signers meta nonce nid sessionPubkey rpc = mkCommand' [] sessionPubkey encodedPayload where encodedPayload = BSL.toStrict $ A.encode payload payload = Payload rpc nonce meta signers nid @@ -363,8 +369,8 @@ cmdToRequestKey Command {..} = RequestKey (toUntypedHash _cmdHash) -type ApplyCmd l = ExecutionMode -> Maybe Signer -> Command ByteString -> IO (CommandResult l) -type ApplyPPCmd m a l = ExecutionMode -> Maybe Signer -> Command ByteString -> ProcessedCommand m a -> IO (CommandResult l) +type ApplyCmd l = ExecutionMode -> Command ByteString -> IO (CommandResult l) +type ApplyPPCmd m a l = ExecutionMode -> Command ByteString -> ProcessedCommand m a -> IO (CommandResult l) data CommandExecInterface m a l = CommandExecInterface { _ceiApplyCmd :: ApplyCmd l diff --git a/src/Pact/Types/SigData.hs b/src/Pact/Types/SigData.hs index a11beccf9..fda2c7318 100644 --- a/src/Pact/Types/SigData.hs +++ b/src/Pact/Types/SigData.hs @@ -105,7 +105,8 @@ sigDataToCommand (SigData h sigList (Just c)) = do let sigMap = M.fromList sigList -- It is ok to use a map here because we're iterating over the signers list and only using the map for lookup. let sigs = catMaybes $ map (\signer -> join $ M.lookup (PublicKeyHex $ _siPubKey signer) sigMap) $ _pSigners payload - pure $ Command c sigs h + let sessionPubkey = Nothing + pure $ Command c sigs sessionPubkey h sampleSigData :: SigData Text sampleSigData = SigData (either error id $ fromText' "b57_gSRIwDEo6SAYseppem57tykcEJkmbTFlCHDs0xc") From 911298a4fee8bfbf45c46c4c2125bf63beff5b6b Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Wed, 5 Apr 2023 08:39:51 -0700 Subject: [PATCH 13/26] Remove sessionPubkey from ApiReq --- src-ghc/Pact/ApiReq.hs | 41 +++++++++++++---------------------------- 1 file changed, 13 insertions(+), 28 deletions(-) diff --git a/src-ghc/Pact/ApiReq.hs b/src-ghc/Pact/ApiReq.hs index 609425c30..09eed77a6 100644 --- a/src-ghc/Pact/ApiReq.hs +++ b/src-ghc/Pact/ApiReq.hs @@ -143,8 +143,7 @@ data ApiReq = ApiReq { _ylSigners :: Maybe [ApiSigner], _ylNonce :: Maybe Text, _ylPublicMeta :: Maybe ApiPublicMeta, - _ylNetworkId :: Maybe NetworkId, - _ylSessionPubkey :: Maybe PublicKeyText + _ylNetworkId :: Maybe NetworkId } deriving (Eq,Show,Generic) instance ToJSON ApiReq where toJSON = lensyToJSON 3 instance FromJSON ApiReq where parseJSON = lensyParseJSON 3 @@ -403,8 +402,8 @@ mkApiReqExec unsignedReq ar@ApiReq{..} fp = do return (code,cdata) pubMeta <- mkPubMeta _ylPublicMeta cmd <- withKeypairsOrSigner unsignedReq ar - (\ks -> mkExec code cdata pubMeta ks _ylNetworkId _ylNonce _ylSessionPubkey) - (\ss -> mkUnsignedExec code cdata pubMeta ss _ylNetworkId _ylNonce _ylSessionPubkey) + (\ks -> mkExec code cdata pubMeta ks _ylNetworkId _ylNonce) + (\ss -> mkUnsignedExec code cdata pubMeta ss _ylNetworkId _ylNonce) return ((ar,code,cdata,pubMeta), cmd) mkPubMeta :: Maybe ApiPublicMeta -> IO PublicMeta @@ -444,17 +443,15 @@ mkExec -- ^ optional 'NetworkId' -> Maybe Text -- ^ optional nonce - -> Maybe PublicKeyText - -- ^ optional session pubkey -> IO (Command Text) -mkExec code mdata pubMeta kps nid ridm mSessionPubkey = do +mkExec code mdata pubMeta kps nid ridm = do rid <- mkNonce ridm cmd <- mkCommand kps pubMeta rid nid - (fmap convertKey mSessionPubkey) + Nothing (Exec (ExecMsg code mdata)) return $ decodeUtf8 <$> cmd @@ -473,17 +470,15 @@ mkUnsignedExec -- ^ optional 'NetworkId' -> Maybe Text -- ^ optional nonce - -> Maybe PublicKeyText - -- ^ optional session pubkey -> IO (Command Text) -mkUnsignedExec code mdata pubMeta kps nid ridm sessionPubkey = do +mkUnsignedExec code mdata pubMeta kps nid ridm = do rid <- mkNonce ridm cmd <- mkUnsignedCommand kps pubMeta rid nid - (fmap convertKey sessionPubkey) + Nothing (Exec (ExecMsg code mdata)) return $ decodeUtf8 <$> cmd @@ -514,8 +509,8 @@ mkApiReqCont unsignedReq ar@ApiReq{..} fp = do let pactId = toPactId apiPactId pubMeta <- mkPubMeta _ylPublicMeta cmd <- withKeypairsOrSigner unsignedReq ar - (\ks -> mkCont pactId step rollback cdata pubMeta ks _ylNonce _ylProof _ylNetworkId _ylSessionPubkey) - (\ss -> mkUnsignedCont pactId step rollback cdata pubMeta ss _ylNonce _ylProof _ylNetworkId _ylSessionPubkey) + (\ks -> mkCont pactId step rollback cdata pubMeta ks _ylNonce _ylProof _ylNetworkId) + (\ss -> mkUnsignedCont pactId step rollback cdata pubMeta ss _ylNonce _ylProof _ylNetworkId) return ((ar,"",cdata,pubMeta), cmd) -- | Construct a Cont request message @@ -539,16 +534,15 @@ mkCont -- ^ optional continuation proof (required for cross-chain) -> Maybe NetworkId -- ^ optional network id - -> Maybe PublicKeyText -> IO (Command Text) -mkCont txid step rollback mdata pubMeta kps ridm proof nid sessionPubkey = do +mkCont txid step rollback mdata pubMeta kps ridm proof nid = do rid <- mkNonce ridm cmd <- mkCommand kps pubMeta rid nid - (fmap convertKey sessionPubkey) + Nothing (Continuation (ContMsg txid step rollback mdata proof) :: (PactRPC ContMsg)) return $ decodeUtf8 <$> cmd @@ -574,17 +568,15 @@ mkUnsignedCont -- ^ optional continuation proof (required for cross-chain) -> Maybe NetworkId -- ^ optional network id - -> Maybe PublicKeyText - -- ^ optional session public key -> IO (Command Text) -mkUnsignedCont txid step rollback mdata pubMeta kps ridm proof nid sessionPubkey = do +mkUnsignedCont txid step rollback mdata pubMeta kps ridm proof nid = do rid <- mkNonce ridm cmd <- mkUnsignedCommand kps pubMeta (pack $ show rid) nid - (convertKey <$> sessionPubkey) + Nothing (Continuation (ContMsg txid step rollback mdata proof) :: (PactRPC ContMsg)) return $ decodeUtf8 <$> cmd @@ -641,12 +633,5 @@ dieAR errMsg = throwM . userError $ intercalate "\n" $ ," step: step index to continue" ," rollback: rollback/cancel flag" ," proof: platform-specific continuation proof data" - ," sessionKey: the public key representing a user with an active session" ,"Error message: " ++ errMsg ] - --- convertKey :: PublicKeyBS -> PublicKeyText --- convertKey (PubBS pkey) = trace (show pkey) $ PublicKeyText (decodeUtf8 pkey) - -convertKey :: a -> a -convertKey = id From 6434715148fa45cb4b79252cdf3d936219fe615b Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Wed, 5 Apr 2023 08:46:04 -0700 Subject: [PATCH 14/26] tests fixup --- tests/GoldenSpec.hs | 4 ++-- tests/HistoryServiceSpec.hs | 2 +- tests/SchemeSpec.hs | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/GoldenSpec.hs b/tests/GoldenSpec.hs index 2d142a9be..468b5b401 100644 --- a/tests/GoldenSpec.hs +++ b/tests/GoldenSpec.hs @@ -152,8 +152,8 @@ doCRTest' ec tn code = beforeAllWith initRes $ where initRes s = do let dbEnv = PactDbEnv (view (rEnv . eePactDb) s) (view (rEnv . eePactDbVar) s) - cmd = Command payload [] initialHash - payload = Payload exec "" pubMeta [] Nothing Nothing + cmd = Command payload [] Nothing initialHash + payload = Payload exec "" pubMeta [] Nothing pubMeta = def parsedCode = either error id $ parsePact code exec = Exec $ ExecMsg parsedCode Null diff --git a/tests/HistoryServiceSpec.hs b/tests/HistoryServiceSpec.hs index 3e71d649c..c74c605f2 100644 --- a/tests/HistoryServiceSpec.hs +++ b/tests/HistoryServiceSpec.hs @@ -33,7 +33,7 @@ dbg :: String -> IO () dbg = const $ return () cmd :: Command ByteString -cmd = Command "" [] initialHash +cmd = Command "" [] Nothing initialHash rq :: RequestKey rq = RequestKey pactInitialHash diff --git a/tests/SchemeSpec.hs b/tests/SchemeSpec.hs index e753db05b..6ab632895 100644 --- a/tests/SchemeSpec.hs +++ b/tests/SchemeSpec.hs @@ -70,7 +70,7 @@ toApiKeyPairs kps = map makeAKP kps mkCommandTest :: [SomeKeyPairCaps] -> [Signer] -> Text -> IO (Command ByteString) -mkCommandTest kps signers code = mkCommand' kps $ toExecPayload signers code +mkCommandTest kps signers code = mkCommand' kps Nothing $ toExecPayload signers code toSigners :: [(PublicKeyBS, PrivateKeyBS, Address, PPKScheme)] -> IO [Signer] @@ -82,7 +82,7 @@ toSigners kps = return $ map makeSigner kps toExecPayload :: [Signer] -> Text -> ByteString toExecPayload signers t = BSL.toStrict $ A.encode payload where - payload = Payload (Exec (ExecMsg t Null)) "nonce" () signers Nothing Nothing + payload = Payload (Exec (ExecMsg t Null)) "nonce" () signers Nothing shouldBeProcFail :: ProcessedCommand () ParsedCode -> Expectation From 024173e39595fff79f05fd400630b3c902d6bf76 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Wed, 5 Apr 2023 08:49:26 -0700 Subject: [PATCH 15/26] Revert "Update hashed payloads in continuation tests" This reverts commit 6fb10daef99dd8a22844fd28761cd46010f02518. --- tests/cont-scripts/fail-both-price-down-01-cont-badcaps.yaml | 2 +- tests/cont-scripts/fail-both-price-up-01-cont.yaml | 2 +- tests/cont-scripts/fail-cred-finish-01-cont.yaml | 2 +- tests/cont-scripts/fail-deb-cancel-01-rollback.yaml | 2 +- tests/cont-scripts/fail-deb-finish-01-cont.yaml | 2 +- tests/cont-scripts/pass-both-price-down-01-cont.yaml | 2 +- tests/cont-scripts/pass-cred-cancel-02-rollback.yaml | 2 +- tests/cont-scripts/pass-deb-cancel-02-rollback.yaml | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/cont-scripts/fail-both-price-down-01-cont-badcaps.yaml b/tests/cont-scripts/fail-both-price-down-01-cont-badcaps.yaml index 8d677a260..9171afe8e 100644 --- a/tests/cont-scripts/fail-both-price-down-01-cont-badcaps.yaml +++ b/tests/cont-scripts/fail-both-price-down-01-cont-badcaps.yaml @@ -1,7 +1,7 @@ # Both debtor and creditor can finish together if price remains the same # or negotiated down BUT bad caps ruin the day. type: "cont" -pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" +pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" step: 1 rollback: False data: {final-price: 1.75} diff --git a/tests/cont-scripts/fail-both-price-up-01-cont.yaml b/tests/cont-scripts/fail-both-price-up-01-cont.yaml index 8dee5aef6..e4b1e3c7a 100644 --- a/tests/cont-scripts/fail-both-price-up-01-cont.yaml +++ b/tests/cont-scripts/fail-both-price-up-01-cont.yaml @@ -1,6 +1,6 @@ # Both debtor and creditor can finish together, but cannot negotiate price up type: "cont" -pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" +pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" step: 1 rollback: False data: {final-price: 12.0} diff --git a/tests/cont-scripts/fail-cred-finish-01-cont.yaml b/tests/cont-scripts/fail-cred-finish-01-cont.yaml index de026549a..7e95a7b78 100644 --- a/tests/cont-scripts/fail-cred-finish-01-cont.yaml +++ b/tests/cont-scripts/fail-cred-finish-01-cont.yaml @@ -1,6 +1,6 @@ # Creditor (Bob) cannot finish alone type: "cont" -pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" +pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" step: 1 rollback: False keyPairs: diff --git a/tests/cont-scripts/fail-deb-cancel-01-rollback.yaml b/tests/cont-scripts/fail-deb-cancel-01-rollback.yaml index 33b40bbf3..5bb8116f0 100644 --- a/tests/cont-scripts/fail-deb-cancel-01-rollback.yaml +++ b/tests/cont-scripts/fail-deb-cancel-01-rollback.yaml @@ -1,6 +1,6 @@ # Debtor (Alice) cannot cancel pre-timeout type: "cont" -pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" +pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" step: 0 rollback: True keyPairs: diff --git a/tests/cont-scripts/fail-deb-finish-01-cont.yaml b/tests/cont-scripts/fail-deb-finish-01-cont.yaml index 3e16a66a3..65d8348ea 100644 --- a/tests/cont-scripts/fail-deb-finish-01-cont.yaml +++ b/tests/cont-scripts/fail-deb-finish-01-cont.yaml @@ -1,6 +1,6 @@ # Debtor (Alice) cannot finish alone type: "cont" -pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" +pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" step: 1 rollback: False keyPairs: diff --git a/tests/cont-scripts/pass-both-price-down-01-cont.yaml b/tests/cont-scripts/pass-both-price-down-01-cont.yaml index a94ed9a2b..1c9e88c44 100644 --- a/tests/cont-scripts/pass-both-price-down-01-cont.yaml +++ b/tests/cont-scripts/pass-both-price-down-01-cont.yaml @@ -1,7 +1,7 @@ # Both debtor and creditor can finish together if price remains the same # or negotiated down. type: "cont" -pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" +pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" step: 1 rollback: False data: {final-price: 1.75} diff --git a/tests/cont-scripts/pass-cred-cancel-02-rollback.yaml b/tests/cont-scripts/pass-cred-cancel-02-rollback.yaml index c47eae13c..3270e4d6d 100644 --- a/tests/cont-scripts/pass-cred-cancel-02-rollback.yaml +++ b/tests/cont-scripts/pass-cred-cancel-02-rollback.yaml @@ -1,6 +1,6 @@ # Creditor (Bob) can cancel anytime type: "cont" -pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" +pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" step: 0 rollback: True keyPairs: diff --git a/tests/cont-scripts/pass-deb-cancel-02-rollback.yaml b/tests/cont-scripts/pass-deb-cancel-02-rollback.yaml index 28431da4f..c1767a75d 100644 --- a/tests/cont-scripts/pass-deb-cancel-02-rollback.yaml +++ b/tests/cont-scripts/pass-deb-cancel-02-rollback.yaml @@ -1,6 +1,6 @@ # Debtor (Alice) can cancel after timeout type: "cont" -pactTxHash: "IalPmD_ipfDg2AlYDwM5lW2JIiE2QaNYTsi60hPkWdQ" +pactTxHash: "L2N2SgjdQAHNEu6WY82VAa4LyxmqfrAuaR6sB41DUMQ" step: 0 rollback: True keyPairs: From a1926d2cb2bd37634d3de33ea236647b1fd8344e Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Wed, 5 Apr 2023 09:53:31 -0700 Subject: [PATCH 16/26] Remove sessionPubkey from command too --- src-ghc/Pact/ApiReq.hs | 4 --- src-ghc/Pact/Bench.hs | 2 +- src-ghc/Pact/Server/History/Persistence.hs | 1 - src-ghc/Pact/Server/History/Service.hs | 2 +- src-ghc/Pact/Server/PactService.hs | 18 ++++++------- src/Pact/Types/Command.hs | 31 +++++++++------------- src/Pact/Types/SigData.hs | 3 +-- tests/GoldenSpec.hs | 2 +- tests/HistoryServiceSpec.hs | 2 +- tests/SchemeSpec.hs | 2 +- 10 files changed, 28 insertions(+), 39 deletions(-) diff --git a/src-ghc/Pact/ApiReq.hs b/src-ghc/Pact/ApiReq.hs index 09eed77a6..75a09eb9c 100644 --- a/src-ghc/Pact/ApiReq.hs +++ b/src-ghc/Pact/ApiReq.hs @@ -451,7 +451,6 @@ mkExec code mdata pubMeta kps nid ridm = do pubMeta rid nid - Nothing (Exec (ExecMsg code mdata)) return $ decodeUtf8 <$> cmd @@ -478,7 +477,6 @@ mkUnsignedExec code mdata pubMeta kps nid ridm = do pubMeta rid nid - Nothing (Exec (ExecMsg code mdata)) return $ decodeUtf8 <$> cmd @@ -542,7 +540,6 @@ mkCont txid step rollback mdata pubMeta kps ridm proof nid = do pubMeta rid nid - Nothing (Continuation (ContMsg txid step rollback mdata proof) :: (PactRPC ContMsg)) return $ decodeUtf8 <$> cmd @@ -576,7 +573,6 @@ mkUnsignedCont txid step rollback mdata pubMeta kps ridm proof nid = do pubMeta (pack $ show rid) nid - Nothing (Continuation (ContMsg txid step rollback mdata proof) :: (PactRPC ContMsg)) return $ decodeUtf8 <$> cmd diff --git a/src-ghc/Pact/Bench.hs b/src-ghc/Pact/Bench.hs index 9ac78c8f6..5e454ec21 100644 --- a/src-ghc/Pact/Bench.hs +++ b/src-ghc/Pact/Bench.hs @@ -234,7 +234,7 @@ benchReadValue _ (TxTable _t) _k = rcp Nothing mkBenchCmd :: [SomeKeyPairCaps] -> (String, Text) -> IO (String, Command ByteString) mkBenchCmd kps (str, t) = do - cmd <- mkCommand' kps Nothing + cmd <- mkCommand' kps $ toStrict . encode $ Payload payload "nonce" () ss Nothing return (str, cmd) diff --git a/src-ghc/Pact/Server/History/Persistence.hs b/src-ghc/Pact/Server/History/Persistence.hs index 4a00e9f8d..8c6560156 100644 --- a/src-ghc/Pact/Server/History/Persistence.hs +++ b/src-ghc/Pact/Server/History/Persistence.hs @@ -160,7 +160,6 @@ selectAllCommands e = do let rowToCmd [SText (Utf8 hash'),SText (Utf8 cmd'),SText (Utf8 userSigs')] = Command { _cmdPayload = cmd' , _cmdSigs = userSigsFromField userSigs' - , _cmdSessionPubKey = Nothing , _cmdHash = fromUntypedHash $ hashFromField hash'} rowToCmd err = error $ "selectAllCommands: unexpected result schema: " ++ show err fmap rowToCmd <$> qrys_ (_qrySelectAllCmds e) [RText,RText,RText] diff --git a/src-ghc/Pact/Server/History/Service.hs b/src-ghc/Pact/Server/History/Service.hs index db88cdab3..b77196ca4 100644 --- a/src-ghc/Pact/Server/History/Service.hs +++ b/src-ghc/Pact/Server/History/Service.hs @@ -245,7 +245,7 @@ _testHistoryDB = do _go :: HistoryService () _go = do - addNewKeys [Command "" [] Nothing initialHash] + addNewKeys [Command "" [] initialHash] let rq = RequestKey pactInitialHash res = PactResult $ Left $ PactError TxFailure def def . viaShow $ ("some error message" :: String) updateExistingKeys (HashMap.fromList [(rq, CommandResult rq Nothing res (Gas 0) Nothing Nothing Nothing [])]) diff --git a/src-ghc/Pact/Server/PactService.hs b/src-ghc/Pact/Server/PactService.hs index 4d6cb02af..d6dfe5039 100644 --- a/src-ghc/Pact/Server/PactService.hs +++ b/src-ghc/Pact/Server/PactService.hs @@ -142,30 +142,30 @@ fullToHashLogCr full = (pactHash . BSL.toStrict . encode) full runPayload :: Command (Payload PublicMeta ParsedCode) -> CommandM p (CommandResult Hash) runPayload c@Command{..} = do case (_pPayload _cmdPayload) of - Exec pm -> applyExec (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) _cmdSessionPubKey pm - Continuation ym -> applyContinuation (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) _cmdSessionPubKey ym + Exec pm -> applyExec (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) pm + Continuation ym -> applyContinuation (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) ym -applyExec :: RequestKey -> PactHash -> [Signer] -> Maybe PublicKeyText -> ExecMsg ParsedCode -> CommandM p (CommandResult Hash) -applyExec rk hsh signers sessionPubkey (ExecMsg parsedCode edata) = do +applyExec :: RequestKey -> PactHash -> [Signer] -> ExecMsg ParsedCode -> CommandM p (CommandResult Hash) +applyExec rk hsh signers (ExecMsg parsedCode edata) = do CommandEnv {..} <- ask when (null (_pcExps parsedCode)) $ throwCmdEx "No expressions found" evalEnv <- liftIO $ setupEvalEnv _ceDbEnv _ceEntity _ceMode - (MsgData edata Nothing (toUntypedHash hsh) signers) - sessionPubkey initRefStore _ceGasEnv permissiveNamespacePolicy + (MsgData edata Nothing (toUntypedHash hsh) signers) Nothing + initRefStore _ceGasEnv permissiveNamespacePolicy _ceSPVSupport _cePublicData _ceExecutionConfig EvalResult{..} <- liftIO $ evalExec defaultInterpreter evalEnv parsedCode mapM_ (\p -> liftIO $ logLog _ceLogger "DEBUG" $ "applyExec: new pact added: " ++ show p) _erExec return $ resultSuccess _erTxId rk _erGas (last _erOutput) _erExec _erLogs _erEvents -applyContinuation :: RequestKey -> PactHash -> [Signer] -> Maybe PublicKeyText -> ContMsg -> CommandM p (CommandResult Hash) -applyContinuation rk hsh signers sessionSigner cm = do +applyContinuation :: RequestKey -> PactHash -> [Signer] -> ContMsg -> CommandM p (CommandResult Hash) +applyContinuation rk hsh signers cm = do CommandEnv{..} <- ask -- Setup environment and get result evalEnv <- liftIO $ setupEvalEnv _ceDbEnv _ceEntity _ceMode - (MsgData (_cmData cm) Nothing (toUntypedHash hsh) signers) sessionSigner initRefStore + (MsgData (_cmData cm) Nothing (toUntypedHash hsh) signers) Nothing initRefStore _ceGasEnv permissiveNamespacePolicy _ceSPVSupport _cePublicData _ceExecutionConfig EvalResult{..} <- liftIO $ evalContinuation defaultInterpreter evalEnv cm return $ resultSuccess _erTxId rk _erGas (last _erOutput) _erExec _erLogs _erEvents diff --git a/src/Pact/Types/Command.hs b/src/Pact/Types/Command.hs index 127088f8b..0c8cfae07 100644 --- a/src/Pact/Types/Command.hs +++ b/src/Pact/Types/Command.hs @@ -25,7 +25,7 @@ -- module Pact.Types.Command - ( Command(..),cmdPayload,cmdSigs,cmdSessionPubKey,cmdHash + ( Command(..),cmdPayload,cmdSigs,cmdHash #if !defined(ghcjs_HOST_OS) , mkCommand , mkCommand' @@ -63,7 +63,7 @@ import Data.Serialize as SZ import Data.Hashable (Hashable) import Data.Aeson as A import Data.Text (Text) -import Data.Maybe (fromMaybe, maybeToList) +import Data.Maybe (fromMaybe) import GHC.Generics @@ -94,23 +94,20 @@ import Pact.Types.Scheme (PPKScheme(..), defPPKScheme) data Command a = Command { _cmdPayload :: !a , _cmdSigs :: ![UserSig] - , _cmdSessionPubKey :: Maybe PublicKeyText , _cmdHash :: !PactHash } deriving (Eq,Show,Ord,Generic,Functor,Foldable,Traversable) instance (Serialize a) => Serialize (Command a) instance (ToJSON a) => ToJSON (Command a) where - toJSON (Command payload uSigs sessionPubkey hsh) = + toJSON (Command payload uSigs hsh) = object $ [ "cmd" .= payload , "sigs" .= toJSON uSigs , "hash" .= hsh - ] ++ maybeToList (("session_pubkey" .=) <$> sessionPubkey) + ] instance (FromJSON a) => FromJSON (Command a) where - parseJSON = withObject "Command" $ \o -> do - _cmdPayload <- o .: "cmd" - _cmdSigs <- o .: "sigs" >>= parseJSON - _cmdSessionPubKey <- (fmap . fmap) PublicKeyText $ o .:? "session_pubkey" - _cmdHash <- o .: "hash" - return $ Command { _cmdPayload, _cmdSigs, _cmdSessionPubKey, _cmdHash } + parseJSON = withObject "Command" $ \o -> + Command <$> (o .: "cmd") + <*> (o .: "sigs" >>= parseJSON) + <*> (o .: "hash") {-# INLINE parseJSON #-} instance NFData a => NFData (Command a) @@ -136,10 +133,9 @@ mkCommand -> m -> Text -> Maybe NetworkId - -> Maybe PublicKeyText -> PactRPC c -> IO (Command ByteString) -mkCommand creds meta nonce nid sessionPubkey rpc = mkCommand' creds sessionPubkey encodedPayload +mkCommand creds meta nonce nid rpc = mkCommand' creds encodedPayload where encodedPayload = BSL.toStrict $ A.encode payload payload = Payload rpc nonce meta (keyPairsToSigners creds) nid @@ -158,12 +154,12 @@ keyPairsToSigners :: [SomeKeyPairCaps] -> [Signer] keyPairsToSigners creds = map (uncurry keyPairToSigner) creds -mkCommand' :: [(SomeKeyPair,a)] -> Maybe PublicKeyText -> ByteString -> IO (Command ByteString) -mkCommand' creds sessionPubkey env = do +mkCommand' :: [(SomeKeyPair,a)] -> ByteString -> IO (Command ByteString) +mkCommand' creds env = do let hsh = hash env -- hash associated with a Command, aka a Command's Request Key toUserSig (cred,_) = signHash hsh cred sigs <- traverse toUserSig creds - return $ Command env sigs sessionPubkey hsh + return $ Command env sigs hsh mkUnsignedCommand :: ToJSON m @@ -172,10 +168,9 @@ mkUnsignedCommand -> m -> Text -> Maybe NetworkId - -> Maybe PublicKeyText -> PactRPC c -> IO (Command ByteString) -mkUnsignedCommand signers meta nonce nid sessionPubkey rpc = mkCommand' [] sessionPubkey encodedPayload +mkUnsignedCommand signers meta nonce nid rpc = mkCommand' [] encodedPayload where encodedPayload = BSL.toStrict $ A.encode payload payload = Payload rpc nonce meta signers nid diff --git a/src/Pact/Types/SigData.hs b/src/Pact/Types/SigData.hs index fda2c7318..a11beccf9 100644 --- a/src/Pact/Types/SigData.hs +++ b/src/Pact/Types/SigData.hs @@ -105,8 +105,7 @@ sigDataToCommand (SigData h sigList (Just c)) = do let sigMap = M.fromList sigList -- It is ok to use a map here because we're iterating over the signers list and only using the map for lookup. let sigs = catMaybes $ map (\signer -> join $ M.lookup (PublicKeyHex $ _siPubKey signer) sigMap) $ _pSigners payload - let sessionPubkey = Nothing - pure $ Command c sigs sessionPubkey h + pure $ Command c sigs h sampleSigData :: SigData Text sampleSigData = SigData (either error id $ fromText' "b57_gSRIwDEo6SAYseppem57tykcEJkmbTFlCHDs0xc") diff --git a/tests/GoldenSpec.hs b/tests/GoldenSpec.hs index 468b5b401..a108af694 100644 --- a/tests/GoldenSpec.hs +++ b/tests/GoldenSpec.hs @@ -152,7 +152,7 @@ doCRTest' ec tn code = beforeAllWith initRes $ where initRes s = do let dbEnv = PactDbEnv (view (rEnv . eePactDb) s) (view (rEnv . eePactDbVar) s) - cmd = Command payload [] Nothing initialHash + cmd = Command payload [] initialHash payload = Payload exec "" pubMeta [] Nothing pubMeta = def parsedCode = either error id $ parsePact code diff --git a/tests/HistoryServiceSpec.hs b/tests/HistoryServiceSpec.hs index c74c605f2..3e71d649c 100644 --- a/tests/HistoryServiceSpec.hs +++ b/tests/HistoryServiceSpec.hs @@ -33,7 +33,7 @@ dbg :: String -> IO () dbg = const $ return () cmd :: Command ByteString -cmd = Command "" [] Nothing initialHash +cmd = Command "" [] initialHash rq :: RequestKey rq = RequestKey pactInitialHash diff --git a/tests/SchemeSpec.hs b/tests/SchemeSpec.hs index 6ab632895..d8b0551f7 100644 --- a/tests/SchemeSpec.hs +++ b/tests/SchemeSpec.hs @@ -70,7 +70,7 @@ toApiKeyPairs kps = map makeAKP kps mkCommandTest :: [SomeKeyPairCaps] -> [Signer] -> Text -> IO (Command ByteString) -mkCommandTest kps signers code = mkCommand' kps Nothing $ toExecPayload signers code +mkCommandTest kps signers code = mkCommand' kps $ toExecPayload signers code toSigners :: [(PublicKeyBS, PrivateKeyBS, Address, PPKScheme)] -> IO [Signer] From 3a5cc7033d7272c04215df1672d0f94a5bab44f4 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Wed, 5 Apr 2023 13:19:12 -0700 Subject: [PATCH 17/26] fix cap filtering in sessionPubKey check --- src/Pact/Eval.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Pact/Eval.hs b/src/Pact/Eval.hs index 623224ee9..226be388f 100644 --- a/src/Pact/Eval.hs +++ b/src/Pact/Eval.hs @@ -152,11 +152,13 @@ enforceKeySetSession :: PureSysOnly e => Info -> Maybe KeySetName -> KeySet -> E enforceKeySetSession i ksn KeySet{..} = do sessionPubKey <- view eeSessionSig case sessionPubKey of - Nothing -> evalError i "enforce-session called while there is no session pubkey in the environment" + Nothing -> error "enforce-session called while there is no session pubkey in the environment" Just (publicKeyText, caps) -> do - sigs' <- checkSigCaps (M.singleton publicKeyText caps) + let matchingKeys = M.filterWithKey matchKey $ M.singleton publicKeyText caps + sigs' <- checkSigCaps matchingKeys runPred (M.size sigs') where + matchKey k _ = k `elem` _ksKeys failed = failTx i $ "Keyset failure " <> parens (pretty _ksPredFun) <> ": " <> maybe (pretty $ map (elide . asString) $ toList _ksKeys) pretty ksn atLeast t m = m >= t From 1ee475e66fee4b25e2bbace6e592e1f79b882819 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Wed, 5 Apr 2023 16:01:23 -0700 Subject: [PATCH 18/26] cleanup --- docs/en/pact-functions.md | 7 +++++-- src/Pact/Native/Session.hs | 8 +++----- src/Pact/Repl/Lib.hs | 5 ++--- src/Pact/Types/Command.hs | 9 ++++----- 4 files changed, 14 insertions(+), 15 deletions(-) diff --git a/docs/en/pact-functions.md b/docs/en/pact-functions.md index 637cef2ed..b0e065d2c 100644 --- a/docs/en/pact-functions.md +++ b/docs/en/pact-functions.md @@ -1782,7 +1782,7 @@ pact> (scalar-mult 'g1 {'x: 1, 'y: 2} 2) *keysetname* `string` *→* `bool` -Enforce that the current environment contains a session signer with a key that satisfies the keyset parameter. The execution environment is responsible for setting the session signer, usually in response to an authorization flow. +Enforce that the current environment contains a session pubkey that satisfies the keyset parameter. The execution environment is responsible for setting the session pubkey, usually in response to an authorization flow. ```lisp (enforce-session keyset) ``` @@ -2047,7 +2047,10 @@ Install a managed namespace policy specifying ALLOW-ROOT and NS-POLICY-FUN. *public-key* `string` *caps* `[string]` *→* `string` - +Set PUBLIC-KEY as the session public key. +```lisp +(env-session "my-key" []) +``` ### env-sigs {#env-sigs} diff --git a/src/Pact/Native/Session.hs b/src/Pact/Native/Session.hs index 5b3a6d536..d4980931b 100644 --- a/src/Pact/Native/Session.hs +++ b/src/Pact/Native/Session.hs @@ -12,11 +12,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -module Pact.Native.Session (sessionDefs, enforceSessionDef) where - - import Pact.Eval (enforceKeySetSession) import Pact.Native.Internal(NativeDef, NativeModule, defRNative, funType, tTyBool, tTyGuard, tTyString) +module Pact.Native.Session (sessionDefs, enforceSessionDef) where import Pact.Types.KeySet (KeySetName(..), parseAnyKeysetName) import Pact.Types.Native (RNativeFun) import Pact.Types.Pretty (pretty) @@ -36,9 +34,9 @@ enforceSessionDef = <> funType tTyBool [("keysetname",tTyString)] ) [LitExample "(enforce-session keyset)"] - "Enforce that the current environment contains a session signer with a key \ + "Enforce that the current environment contains a session pubkey \ \that satisfies the keyset parameter. The execution environment is \ - \responsible for setting the session signer, usually in response to an \ + \responsible for setting the session pubkey, usually in response to an \ \authorization flow." where diff --git a/src/Pact/Repl/Lib.hs b/src/Pact/Repl/Lib.hs index 494fdd964..86f7d34d9 100644 --- a/src/Pact/Repl/Lib.hs +++ b/src/Pact/Repl/Lib.hs @@ -127,9 +127,8 @@ replDefs = ("Repl", ("Set transaction signature keys and capabilities. SIGS is a list of objects with \"key\" " <> "specifying the signer key, and \"caps\" specifying a list of associated capabilities.") ,defZNative "env-session" setsession (funType tTyString [("public-key", tTyString), ("caps", TyList tTyString)]) - [] - "" - + [LitExample $ "(env-session \"my-key\" [])"] + "Set PUBLIC-KEY as the session public key." ,defZRNative "env-data" setmsg (funType tTyString [("json",json)]) ["(env-data { \"keyset\": { \"keys\": [\"my-key\" \"admin-key\"], \"pred\": \"keys-any\" } })"] "Set transaction JSON data, either as encoded string, or as pact types coerced to JSON." diff --git a/src/Pact/Types/Command.hs b/src/Pact/Types/Command.hs index 0c8cfae07..14c62510a 100644 --- a/src/Pact/Types/Command.hs +++ b/src/Pact/Types/Command.hs @@ -10,7 +10,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} @@ -99,10 +98,10 @@ data Command a = Command instance (Serialize a) => Serialize (Command a) instance (ToJSON a) => ToJSON (Command a) where toJSON (Command payload uSigs hsh) = - object $ [ "cmd" .= payload - , "sigs" .= toJSON uSigs - , "hash" .= hsh - ] + object [ "cmd" .= payload + , "sigs" .= toJSON uSigs + , "hash" .= hsh + ] instance (FromJSON a) => FromJSON (Command a) where parseJSON = withObject "Command" $ \o -> Command <$> (o .: "cmd") From a810a2ae475d8d9be8eb289e7397719bb52814ee Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Wed, 5 Apr 2023 16:24:27 -0700 Subject: [PATCH 19/26] more cleanup --- src-ghc/Pact/ApiReq.hs | 2 -- src-ghc/Pact/Interpreter.hs | 8 ++++++-- src-ghc/Pact/Server/PactService.hs | 11 +++++------ 3 files changed, 11 insertions(+), 10 deletions(-) diff --git a/src-ghc/Pact/ApiReq.hs b/src-ghc/Pact/ApiReq.hs index 75a09eb9c..143ef8f04 100644 --- a/src-ghc/Pact/ApiReq.hs +++ b/src-ghc/Pact/ApiReq.hs @@ -72,8 +72,6 @@ import Pact.Types.Runtime import Pact.Types.SigData import Pact.Types.SPV --- import Debug.Trace (trace) - -- | For fully-signed commands data ApiKeyPair = ApiKeyPair { _akpSecret :: PrivateKeyBS, diff --git a/src-ghc/Pact/Interpreter.hs b/src-ghc/Pact/Interpreter.hs index a394b428a..30b56fa68 100644 --- a/src-ghc/Pact/Interpreter.hs +++ b/src-ghc/Pact/Interpreter.hs @@ -163,6 +163,9 @@ setupEvalEnv -> ExecutionMode -> MsgData -> Maybe PublicKeyText + -- ^ A session pubkey, indicating that the public key's owner + -- has been authenticated in a session for the scope of this `EvalEnv`. + -- The pubkey is checked during calls to the `enforce-session` builtin. -> RefStore -> GasEnv -> NamespacePolicy @@ -197,9 +200,10 @@ setupEvalEnv dbEnv ent mode msgData sessionPubkey refStore gasEnv np spv pd ec = } where mkMsgSigs ss = M.fromList $ map toPair ss - toPair Signer{..} = (pk,S.fromList _siCapList) where - pk = PublicKeyText $ fromMaybe _siPubKey _siAddress + toPair Signer{..} = (pk,S.fromList _siCapList) + where + pk = PublicKeyText $ fromMaybe _siPubKey _siAddress initRefStore :: RefStore initRefStore = RefStore nativeDefs diff --git a/src-ghc/Pact/Server/PactService.hs b/src-ghc/Pact/Server/PactService.hs index d6dfe5039..23fb21982 100644 --- a/src-ghc/Pact/Server/PactService.hs +++ b/src-ghc/Pact/Server/PactService.hs @@ -63,10 +63,10 @@ initPactService CommandConfig {..} loggers spv = do blockHeight blockTime prevBlockHash spv _ccExecutionConfig eMode cmd (verifyCommand cmd) - , _ceiApplyPPCmd = \eMode cmd -> + , _ceiApplyPPCmd = applyCmd logger _ccEntity p gasModel blockHeight blockTime prevBlockHash - spv _ccExecutionConfig eMode cmd + spv _ccExecutionConfig } case _ccSqlite of Nothing -> do @@ -140,10 +140,9 @@ fullToHashLogCr full = (pactHash . BSL.toStrict . encode) full runPayload :: Command (Payload PublicMeta ParsedCode) -> CommandM p (CommandResult Hash) -runPayload c@Command{..} = do - case (_pPayload _cmdPayload) of - Exec pm -> applyExec (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) pm - Continuation ym -> applyContinuation (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) ym +runPayload c@Command{..} = case (_pPayload _cmdPayload) of + Exec pm -> applyExec (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) pm + Continuation ym -> applyContinuation (cmdToRequestKey c) _cmdHash (_pSigners _cmdPayload) ym applyExec :: RequestKey -> PactHash -> [Signer] -> ExecMsg ParsedCode -> CommandM p (CommandResult Hash) From 125ae0cff01f768bacd5f6a9991d33a89b6acbd3 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Wed, 5 Apr 2023 16:47:24 -0700 Subject: [PATCH 20/26] fixup --- src/Pact/Native/Session.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Pact/Native/Session.hs b/src/Pact/Native/Session.hs index d4980931b..4fc88cf80 100644 --- a/src/Pact/Native/Session.hs +++ b/src/Pact/Native/Session.hs @@ -12,9 +12,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +module Pact.Native.Session + ( sessionDefs + , enforceSessionDef + ) where + import Pact.Eval (enforceKeySetSession) import Pact.Native.Internal(NativeDef, NativeModule, defRNative, funType, tTyBool, tTyGuard, tTyString) -module Pact.Native.Session (sessionDefs, enforceSessionDef) where import Pact.Types.KeySet (KeySetName(..), parseAnyKeysetName) import Pact.Types.Native (RNativeFun) import Pact.Types.Pretty (pretty) From 6184201bb553790657adf1af4d95b2173143f089 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Mon, 10 Apr 2023 13:19:50 -0700 Subject: [PATCH 21/26] Update src/Pact/Native/Session.hs Fix formatting for enforceSession Co-authored-by: John Wiegley --- src/Pact/Native/Session.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Pact/Native/Session.hs b/src/Pact/Native/Session.hs index 4fc88cf80..eef888a36 100644 --- a/src/Pact/Native/Session.hs +++ b/src/Pact/Native/Session.hs @@ -66,6 +66,7 @@ enforceSessionDef = ks <- readRow (getInfo i) KeySets keySetName >>= \case Nothing -> evalError (getInfo i) $ "No such keyset: " <> pretty keySetName Just ks -> pure ks - enforceKeySetSession (getInfo i) (Just keySetName) ks >> return (toTerm True) + enforceKeySetSession (getInfo i) (Just keySetName) ks + return (toTerm True) enforceSession' i as = argsError i as From a33ab264272c2cf997b106bf6e30d124cbca7dc9 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Mon, 10 Apr 2023 13:20:02 -0700 Subject: [PATCH 22/26] Update src-ghc/Pact/GasModel/GasTests.hs Co-authored-by: John Wiegley --- src-ghc/Pact/GasModel/GasTests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-ghc/Pact/GasModel/GasTests.hs b/src-ghc/Pact/GasModel/GasTests.hs index 4f74c8237..620c40ef3 100644 --- a/src-ghc/Pact/GasModel/GasTests.hs +++ b/src-ghc/Pact/GasModel/GasTests.hs @@ -555,7 +555,7 @@ enforceSessionTests = tests tests = createGasUnitTests - updateEnvMsgSession + updateEnvMsgSession updateEnvMsgSession [enforceSessionExpr] From 6173b6e28404becf518e6080de094e047d06041b Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Mon, 10 Apr 2023 13:20:12 -0700 Subject: [PATCH 23/26] Update src/Pact/Native/Session.hs Co-authored-by: John Wiegley --- src/Pact/Native/Session.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Pact/Native/Session.hs b/src/Pact/Native/Session.hs index eef888a36..0344f66e2 100644 --- a/src/Pact/Native/Session.hs +++ b/src/Pact/Native/Session.hs @@ -53,7 +53,8 @@ enforceSessionDef = enforceSession' i [TGuard{_tGuard}] = case _tGuard of GKeySetRef (ksr) -> do ks <- lookupEnvironmentKeyset i ksr - enforceKeySetSession (getInfo i) Nothing ks >> return (toTerm True) + enforceKeySetSession (getInfo i) Nothing ks + return (toTerm True) GKeySet ks -> enforceKeySetSession (getInfo i) Nothing ks >> return (toTerm True) _ -> evalError' i "incorrect guard type, must be keyset ref or keyset" enforceSession' i [TLitString k] = do From b55bd9f87243189716715f9af95376f7cdd0f814 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Mon, 10 Apr 2023 13:20:20 -0700 Subject: [PATCH 24/26] Update src-ghc/Pact/GasModel/GasTests.hs Co-authored-by: John Wiegley --- src-ghc/Pact/GasModel/GasTests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-ghc/Pact/GasModel/GasTests.hs b/src-ghc/Pact/GasModel/GasTests.hs index 620c40ef3..8cb8d1c3b 100644 --- a/src-ghc/Pact/GasModel/GasTests.hs +++ b/src-ghc/Pact/GasModel/GasTests.hs @@ -557,7 +557,7 @@ enforceSessionTests = tests createGasUnitTests updateEnvMsgSession updateEnvMsgSession - [enforceSessionExpr] + [enforceSessionExpr] readKeysetTests :: NativeDefName -> GasUnitTests readKeysetTests = tests From 35d7f4e09b26f965743414da407a30c0e766c520 Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Mon, 10 Apr 2023 15:08:30 -0700 Subject: [PATCH 25/26] cleanup enforceKeysetSession --- src/Pact/Eval.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Pact/Eval.hs b/src/Pact/Eval.hs index 226be388f..aa5b12965 100644 --- a/src/Pact/Eval.hs +++ b/src/Pact/Eval.hs @@ -148,17 +148,23 @@ enforceKeySet i ksn KeySet{..} = do {-# INLINE enforceKeySet #-} -- | Enforce keyset against session key from the environment. +-- This is very similar to `enforceKeyset` (and both could be implemented +-- in terms of a common function), but since `enforceKeyset` is such a central +-- piece of code, we define `enforceKeySetSession` separately for now, and +-- don't modify `enforceKeyset`. enforceKeySetSession :: PureSysOnly e => Info -> Maybe KeySetName -> KeySet -> Eval e () enforceKeySetSession i ksn KeySet{..} = do sessionPubKey <- view eeSessionSig case sessionPubKey of Nothing -> error "enforce-session called while there is no session pubkey in the environment" Just (publicKeyText, caps) -> do - let matchingKeys = M.filterWithKey matchKey $ M.singleton publicKeyText caps + let matchingKeys = + if publicKeyText `elem` _ksKeys + then M.singleton publicKeyText caps + else mempty sigs' <- checkSigCaps matchingKeys runPred (M.size sigs') where - matchKey k _ = k `elem` _ksKeys failed = failTx i $ "Keyset failure " <> parens (pretty _ksPredFun) <> ": " <> maybe (pretty $ map (elide . asString) $ toList _ksKeys) pretty ksn atLeast t m = m >= t From 40d27ff9ba530616efd68862bfe8a043d55c0592 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Mon, 10 Apr 2023 15:18:03 -0700 Subject: [PATCH 26/26] Update src/Pact/Native/Session.hs Co-authored-by: John Wiegley --- src/Pact/Native/Session.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Pact/Native/Session.hs b/src/Pact/Native/Session.hs index 0344f66e2..4275440dd 100644 --- a/src/Pact/Native/Session.hs +++ b/src/Pact/Native/Session.hs @@ -55,7 +55,9 @@ enforceSessionDef = ks <- lookupEnvironmentKeyset i ksr enforceKeySetSession (getInfo i) Nothing ks return (toTerm True) - GKeySet ks -> enforceKeySetSession (getInfo i) Nothing ks >> return (toTerm True) + GKeySet ks -> do + enforceKeySetSession (getInfo i) Nothing ks + return (toTerm True) _ -> evalError' i "incorrect guard type, must be keyset ref or keyset" enforceSession' i [TLitString k] = do keySetName <- ifExecutionFlagSet FlagDisablePact44