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/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,
@@ -449,6 +451,7 @@ mkExec code mdata pubMeta kps nid ridm = do
          pubMeta
          rid
          nid
+         Nothing
          (Exec (ExecMsg code mdata))
   return $ decodeUtf8 <$> cmd
 
@@ -475,6 +478,7 @@ mkUnsignedExec code mdata pubMeta kps nid ridm = do
          pubMeta
          rid
          nid
+         Nothing
          (Exec (ExecMsg code mdata))
   return $ decodeUtf8 <$> cmd
 
@@ -538,6 +542,7 @@ 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
 
@@ -571,6 +576,7 @@ 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
 

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

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,21 @@ setupEvalEnv
   -> Maybe EntityName
   -> ExecutionMode
   -> MsgData
+  -> Maybe PublicKeyText
   -> 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
@@ -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/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]

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

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 =
+          , _ceiApplyPPCmd = \eMode cmd ->
             applyCmd logger _ccEntity p gasModel
             blockHeight blockTime prevBlockHash
-            spv _ccExecutionConfig
+            spv _ccExecutionConfig eMode cmd
           }
   case _ccSqlite of
     Nothing -> do
@@ -140,31 +140,32 @@ 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
+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
 
 
-applyExec :: RequestKey -> PactHash -> [Signer] -> ExecMsg ParsedCode -> CommandM p (CommandResult Hash)
-applyExec rk hsh signers (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)
-        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] -> ContMsg -> CommandM p (CommandResult Hash)
-applyContinuation rk hsh signers cm = do
+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
   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,38 @@ 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
+  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
+    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
   ]