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

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

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

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/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'
@@ -175,6 +176,7 @@ setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do
   pure EvalEnv {
     _eeRefStore = refStore
   , _eeMsgSigs = mkMsgSigs $ mdSigners msgData
+  , _eeSessionSig = toPair <$> mdSessionSigner msgData
   , _eeMsgBody = mdData msgData
   , _eeMode = mode
   , _eeEntity = ent
@@ -195,11 +197,9 @@ setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do
   }
   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

src-ghc/Pact/Server/PactService.hs

@@ -141,30 +141,30 @@ 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
   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] -> 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

src/Pact/Eval.hs

@@ -41,6 +41,7 @@ module Pact.Eval
     ,acquireModuleAdmin
     ,computeUserAppGas,prepareUserAppArgs,evalUserAppBody
     ,evalByName
+    ,enforceKeySetSession
     ,resumePact
     ,enforcePactValue,enforcePactValue'
     ,toPersistDirect
@@ -146,6 +147,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

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,69 @@
+-- |
+-- 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 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

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