diff --git a/docs/en/pact-functions.md b/docs/en/pact-functions.md index a1fa73c64..b0e065d2c 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 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) +``` + ## 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,17 @@ Install a managed namespace policy specifying ALLOW-ROOT and NS-POLICY-FUN. ``` +### env-session {#env-session} + +*public-key* `string` *caps* `[string]` *→* `string` + + +Set PUBLIC-KEY as the session public key. +```lisp +(env-session "my-key" []) +``` + + ### env-sigs {#env-sigs} *sigs* `[object:*]` *→* `string` 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/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-ghc/Pact/Bench.hs b/src-ghc/Pact/Bench.hs index 8180b59b5..5e454ec21 100644 --- a/src-ghc/Pact/Bench.hs +++ b/src-ghc/Pact/Bench.hs @@ -157,7 +157,7 @@ loadBenchModule db = do pactInitialHash [Signer Nothing pk 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 @@ -185,8 +185,8 @@ runPactExec :: Advice -> String -> [Signer] -> Value -> Maybe (ModuleData Ref) - runPactExec pt msg ss cdata benchMod dbEnv pc = do 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 @@ -197,7 +197,7 @@ execPure :: Advice -> PactDbEnv e -> (String,[Term Name]) -> IO [Term Name] execPure pt dbEnv (n,ts) = do 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/GasTests.hs b/src-ghc/Pact/GasModel/GasTests.hs index 0f2d0ce89..8cb8d1c3b 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-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 1327a8692..30b56fa68 100644 --- a/src-ghc/Pact/Interpreter.hs +++ b/src-ghc/Pact/Interpreter.hs @@ -162,6 +162,10 @@ setupEvalEnv -> Maybe EntityName -> 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 @@ -169,12 +173,13 @@ setupEvalEnv -> PublicData -> ExecutionConfig -> IO (EvalEnv e) -setupEvalEnv dbEnv ent mode msgData 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 = fmap (, S.empty) sessionPubkey , _eeMsgBody = mdData msgData , _eeMode = mode , _eeEntity = ent @@ -200,7 +205,6 @@ setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do 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 b2a73083e..23fb21982 100644 --- a/src-ghc/Pact/Server/PactService.hs +++ b/src-ghc/Pact/Server/PactService.hs @@ -151,7 +151,7 @@ applyExec rk hsh signers (ExecMsg parsedCode edata) = do 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) Nothing initRefStore _ceGasEnv permissiveNamespacePolicy _ceSPVSupport _cePublicData _ceExecutionConfig EvalResult{..} <- liftIO $ evalExec defaultInterpreter evalEnv parsedCode @@ -164,7 +164,7 @@ 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) 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/Eval.hs b/src/Pact/Eval.hs index 545ec701d..aa5b12965 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 @@ -146,6 +147,46 @@ enforceKeySet i ksn KeySet{..} = do | otherwise = failed {-# 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 = + if publicKeyText `elem` _ksKeys + then M.singleton publicKeyText caps + else mempty + sigs' <- checkSigCaps matchingKeys + runPred (M.size sigs') + where + 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 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) 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/Native/Session.hs b/src/Pact/Native/Session.hs new file mode 100644 index 000000000..4275440dd --- /dev/null +++ b/src/Pact/Native/Session.hs @@ -0,0 +1,75 @@ +-- | +-- 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 pubkey \ + \that satisfies the keyset parameter. The execution environment is \ + \responsible for setting the session pubkey, 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 -> 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 + (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 diff --git a/src/Pact/Repl.hs b/src/Pact/Repl.hs index b5178b85c..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 diff --git a/src/Pact/Repl/Lib.hs b/src/Pact/Repl/Lib.hs index e599be49a..86f7d34d9 100644 --- a/src/Pact/Repl/Lib.hs +++ b/src/Pact/Repl/Lib.hs @@ -126,7 +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)]) + [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." @@ -402,6 +404,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/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 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))