Add session command data and enforce-session builtin

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`

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)

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

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

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

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

src-ghc/Pact/Interpreter.hs

@@ -162,19 +162,24 @@ 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
   -> SPVSupport
   -> 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
 

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

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

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)

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
   ]
 
 

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 <[email protected]>
+--
+-- 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

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

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] ->

src/Pact/Types/Purity.hs

@@ -73,6 +73,7 @@ mkPureEnv holder purity readRowImpl env@EvalEnv{..} = do
   return $ EvalEnv
     _eeRefStore
     _eeMsgSigs
+    _eeSessionSig
     _eeMsgBody
     _eeMode
     _eeEntity

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