-
Notifications
You must be signed in to change notification settings - Fork 99
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Add session command data and enforce-session
builtin
#1171
base: master
Are you sure you want to change the base?
Changes from 20 commits
2dee0a2
a74509f
625a50a
9d8e9b5
31a425b
1e29182
05ae94e
bfe2ad1
6fb10da
6b228f6
bb25cd3
452198e
911298a
6434715
024173e
a1926d2
3a5cc70
1ee475e
a810a2a
125ae0c
6184201
a33ab26
6173b6e
b55bd9f
35d7f4e
40d27ff
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change | ||||
---|---|---|---|---|---|---|
|
@@ -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 | ||||||
imalsogreg marked this conversation as resolved.
Show resolved
Hide resolved
|
||||||
updateEnvMsgSession | ||||||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more.
Suggested change
|
||||||
[enforceSessionExpr] | ||||||
imalsogreg marked this conversation as resolved.
Show resolved
Hide resolved
|
||||||
|
||||||
readKeysetTests :: NativeDefName -> GasUnitTests | ||||||
readKeysetTests = tests | ||||||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -41,6 +41,7 @@ module Pact.Eval | |
,acquireModuleAdmin | ||
,computeUserAppGas,prepareUserAppArgs,evalUserAppBody | ||
,evalByName | ||
,enforceKeySetSession | ||
,resumePact | ||
,enforcePactValue,enforcePactValue' | ||
,toPersistDirect | ||
|
@@ -146,6 +147,40 @@ 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 -> error "enforce-session called while there is no session pubkey in the environment" | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Do we want to error this hard instead of calling |
||
Just (publicKeyText, caps) -> do | ||
let matchingKeys = M.filterWithKey matchKey $ M.singleton publicKeyText caps | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Is this code just checking whether There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Just a tad more - The code here is confusing. I've tweaked this part to make it more clear. |
||
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 | ||
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 | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,71 @@ | ||
-- | | ||
-- 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) | ||
imalsogreg marked this conversation as resolved.
Show resolved
Hide resolved
|
||
GKeySet ks -> enforceKeySetSession (getInfo i) Nothing ks >> return (toTerm True) | ||
imalsogreg marked this conversation as resolved.
Show resolved
Hide resolved
|
||
_ -> 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) | ||
imalsogreg marked this conversation as resolved.
Show resolved
Hide resolved
|
||
|
||
enforceSession' i as = argsError i as |
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
what's the syntax for a cap here? Can we get a more complex example?