-
Notifications
You must be signed in to change notification settings - Fork 9
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
Principals #22
Principals #22
Changes from 41 commits
04df6ae
76e6d24
8078981
6fe6e7a
a899649
cf26cb4
e5c4fb8
80d1e26
9f00c76
b9c6d7c
2c3073d
01b2f97
7f2f6d7
f90b604
7ada5c3
66d3650
51fd8a8
2ef65fa
592ea1b
d46b91e
f7311ae
11dff88
1a8e579
5ca5af7
75a1d08
d2f6679
3f85a0c
fa43e42
a25a93b
cc233c2
4cb6dce
919927a
4bd4d26
37717f7
cb5fc24
b756a96
f02f0d0
edfb40b
4630f2d
086dcea
f1b7893
87767d6
df81115
57ced6d
9155d43
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Large diffs are not rendered by default.
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -26,12 +26,14 @@ module Pact.Core.IR.Eval.RawBuiltin | |
import Control.Lens hiding (from, to, op, parts) | ||
import Control.Monad(when, unless, foldM) | ||
import Control.Monad.IO.Class | ||
import Data.Attoparsec.Text(parseOnly) | ||
import Data.Containers.ListUtils(nubOrd) | ||
import Data.Bits | ||
import Data.Foldable(foldl', traverse_) | ||
import Data.Either(isRight) | ||
import Data.Foldable(foldl', traverse_, toList) | ||
import Data.Decimal(roundTo', Decimal) | ||
import Data.Vector(Vector) | ||
import Data.Maybe(isJust) | ||
import Data.Maybe(isJust, maybeToList) | ||
import Numeric(showIntAtBase) | ||
import qualified Data.Vector as V | ||
import qualified Data.Vector.Algorithms.Intro as V | ||
|
@@ -56,6 +58,7 @@ import Pact.Core.DefPacts.Types | |
import Pact.Core.Environment | ||
import Pact.Core.Capabilities | ||
import Pact.Core.Namespace | ||
import qualified Pact.Core.Principal as Pr | ||
|
||
import Pact.Core.IR.Term | ||
import Pact.Core.IR.Eval.Runtime | ||
|
@@ -1395,6 +1398,60 @@ coreCompose = \info b cont handler _env -> \case | |
err -> returnCEK cont handler err | ||
args -> argsError info b args | ||
|
||
createPrincipalForGuard :: (Monad m) => Guard FullyQualifiedName PactValue -> m Pr.Principal | ||
createPrincipalForGuard g = do | ||
case g of | ||
GKeyset (KeySet ks pf) -> case (toList ks, pf) of | ||
([k], KeysAll) -> pure $ Pr.K k | ||
(l, _) -> do | ||
h <- mkHash $ map (T.encodeUtf8 . _pubKey) l | ||
pure $ Pr.W (hashToText h) (predicateToString pf) | ||
GKeySetRef ksn -> pure $ Pr.R ksn | ||
GModuleGuard (ModuleGuard mn n) -> pure $ Pr.M mn n | ||
GUserGuard (UserGuard f args) -> do | ||
h <- mkHash $ map encodeStable args | ||
pure $ Pr.U (Pretty.renderText f) (hashToText h) | ||
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. Remove |
||
-- TODO orig pact gets here ^^^^ a Name | ||
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. Todo still pending? 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. Yep. I think we agreed to sort this out later on when dealing with |
||
-- which can be any of QualifiedName/BareName/DynamicName/FQN, | ||
-- and uses the rendered string here. Need to double-check equivalence. | ||
GCapabilityGuard (CapabilityGuard f args pid) -> do | ||
let args' = map encodeStable args | ||
f' = T.encodeUtf8 $ renderQualName $ fqnToQualName f | ||
pid' = T.encodeUtf8 . renderDefPactId <$> pid | ||
h <- mkHash $ f' : args' ++ maybeToList pid' | ||
pure $ Pr.C $ hashToText h | ||
where | ||
mkHash bss = pure $ pactHash $ mconcat bss | ||
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. why the Monad constraint and use of pure? I feel like here a type signature would be beneficial 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. That's for when we'll eventually have gas. It was all in LMK if you'd nevertheless like to purify this function (for now?) 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. Could just make it pure for now. |
||
|
||
coreCreatePrincipal :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m | ||
coreCreatePrincipal info b cont handler _env = \case | ||
[VGuard g] -> do | ||
pr <- createPrincipalForGuard g | ||
returnCEKValue cont handler $ VString $ Pr.mkPrincipalIdent pr | ||
args -> argsError info b args | ||
|
||
coreIsPrincipal :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m | ||
coreIsPrincipal info b cont handler _env = \case | ||
[VString p] -> returnCEKValue cont handler $ VBool $ isRight $ parseOnly Pr.principalParser p | ||
args -> argsError info b args | ||
|
||
coreTypeOfPrincipal :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m | ||
coreTypeOfPrincipal info b cont handler _env = \case | ||
[VString p] -> do | ||
let prty = case parseOnly Pr.principalParser p of | ||
Left _ -> "" | ||
Right pr -> Pr.showPrincipalType pr | ||
returnCEKValue cont handler $ VString prty | ||
args -> argsError info b args | ||
|
||
coreValidatePrincipal :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m | ||
coreValidatePrincipal info b cont handler _env = \case | ||
[VGuard g, VString s] -> do | ||
pr' <- createPrincipalForGuard g | ||
returnCEKValue cont handler $ VBool $ Pr.mkPrincipalIdent pr' == s | ||
args -> argsError info b args | ||
|
||
|
||
-------------------------------------------------- | ||
-- Namespace functions | ||
-------------------------------------------------- | ||
|
@@ -1612,6 +1669,10 @@ rawBuiltinRuntime = \case | |
RawDays -> days | ||
RawCompose -> coreCompose | ||
RawSelectWithFields -> dbSelect | ||
RawCreatePrincipal -> coreCreatePrincipal | ||
RawIsPrincipal -> coreIsPrincipal | ||
RawTypeOfPrincipal -> coreTypeOfPrincipal | ||
RawValidatePrincipal -> coreValidatePrincipal | ||
RawNamespace -> coreNamespace | ||
RawDefineNamespace -> coreDefineNamespace | ||
RawDescribeNamespace -> coreDescribeNamespace |
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.
I feel like this is unnecessary and prefer the usage of
_pubKey
which we might rename as_publicKeyText
?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.
I wanted to make the intent of (stable-)rendering it explicit. And shall we ever change/extend the representation, that'd be easier to achieve.