Skip to content
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

Merged
merged 45 commits into from
Nov 14, 2023
Merged
Show file tree
Hide file tree
Changes from 41 commits
Commits
Show all changes
45 commits
Select commit Hold shift + click to select a range
04df6ae
Some initial principals scaffolding
0xd34df00d Oct 16, 2023
76e6d24
Copy the Principal type over from pact
0xd34df00d Oct 17, 2023
8078981
Principal needs to be a part of PactValue
0xd34df00d Oct 17, 2023
6fe6e7a
Error kind for principals
0xd34df00d Oct 17, 2023
a899649
Depend on pact-json
0xd34df00d Oct 18, 2023
cf26cb4
Expose gas units to simplify porting over legacy pact gassing
0xd34df00d Oct 18, 2023
e5c4fb8
Generalize KSPredicate conversion
0xd34df00d Oct 18, 2023
80d1e26
instance J.Encode (StableEncoding Principal)
0xd34df00d Oct 19, 2023
9f00c76
Some progress on coreCreatePrincipal
0xd34df00d Oct 19, 2023
b9c6d7c
Be more explicit about QN/FQN rendering
0xd34df00d Oct 20, 2023
2c3073d
Expose and use renderPactId for hashing
0xd34df00d Oct 20, 2023
01b2f97
Expand on the comment re FQN/names (and no need to convert FQN to QN)
0xd34df00d Oct 20, 2023
7f2f6d7
Implement mkPrincipalIdent
0xd34df00d Oct 20, 2023
f90b604
Add a TODO about gassing principals
0xd34df00d Oct 20, 2023
7ada5c3
Forgot the module in .cabal
0xd34df00d Oct 20, 2023
66d3650
A tad more concise StableEncoding for Principals
0xd34df00d Oct 20, 2023
51fd8a8
Refactor out principal creation since it's also needed for validation
0xd34df00d Oct 24, 2023
2ef65fa
pattern PBool
0xd34df00d Oct 24, 2023
592ea1b
Add validate-principal
0xd34df00d Oct 24, 2023
d46b91e
Return a VString from create-principal for backcompat
0xd34df00d Oct 24, 2023
f7311ae
Some progress on parsing principals
0xd34df00d Oct 25, 2023
11dff88
{qualified,bare}NameParser's needn't pollute the top-level namespace
0xd34df00d Oct 25, 2023
1a8e579
More precise export list
0xd34df00d Oct 25, 2023
5ca5af7
Parse `r:` principals
0xd34df00d Oct 25, 2023
75a1d08
Parse `u:` principals
0xd34df00d Oct 25, 2023
d2f6679
Less copypaste
0xd34df00d Oct 25, 2023
3f85a0c
Almost all of the rest of the parsers are easy
0xd34df00d Oct 25, 2023
fa43e42
M principals parsing also done, and that concludes parsing
0xd34df00d Oct 25, 2023
a25a93b
Update deps in pact-core.cabal
0xd34df00d Oct 25, 2023
cc233c2
`VPactValue . PBool` ~ `VBool`
0xd34df00d Oct 26, 2023
4cb6dce
is-principal done
0xd34df00d Oct 26, 2023
919927a
Showing principal types
0xd34df00d Oct 26, 2023
4bd4d26
Add repl tests
0xd34df00d Oct 27, 2023
37717f7
Parsing principals
0xd34df00d Oct 27, 2023
cb5fc24
Un-gas principals
0xd34df00d Oct 30, 2023
b756a96
Remove principals from primitive types as per PR comments
0xd34df00d Oct 30, 2023
f02f0d0
Delay predicateToString as much as possible
0xd34df00d Oct 31, 2023
edfb40b
Merge remote-tracking branch 'origin/master' into gr/principals
0xd34df00d Oct 31, 2023
4630f2d
renderPactId → renderDefPactId for consistency
0xd34df00d Oct 31, 2023
086dcea
Un-ImportPostQualified-everything for now
0xd34df00d Oct 31, 2023
f1b7893
Use `maybeToList`
0xd34df00d Oct 31, 2023
87767d6
Merge remote-tracking branch 'origin/master' into gr/principals
0xd34df00d Nov 13, 2023
df81115
Purify `createPrincipalForGuard`
0xd34df00d Nov 13, 2023
57ced6d
Avoid `renderText`
0xd34df00d Nov 13, 2023
9155d43
Enable a part of principals tests that work thanks to having ns now!
0xd34df00d Nov 13, 2023
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
603 changes: 603 additions & 0 deletions pact-core-tests/pact-tests/principals.repl

Large diffs are not rendered by default.

6 changes: 5 additions & 1 deletion pact-core.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ build-type: Simple
common pact-core-common
build-depends:
, Decimal
, attoparsec
, base
, base16-bytestring
, base64-bytestring
Expand All @@ -32,7 +33,9 @@ common pact-core-common
, filepath
, lens
, mtl
, pact-json
, pact-time
, parsers
, prettyprinter
, prettyprinter-ansi-terminal
, transformers
Expand All @@ -52,6 +55,7 @@ common pact-core-common
, array
, pact-json
, scientific
, unordered-containers

ghc-options: -Wall -Werror -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
ghc-prof-options: -fprof-auto -fprof-auto-calls
Expand Down Expand Up @@ -100,6 +104,7 @@ library
Pact.Core.Environment.Utils
Pact.Core.Environment.Types
Pact.Core.StableEncoding
Pact.Core.Principal
Pact.Core.Namespace

-- Syntax modules
Expand Down Expand Up @@ -211,7 +216,6 @@ test-suite core-tests
, bytestring
, containers
, data-default
, unordered-containers
, Decimal
, QuickCheck
, deepseq
Expand Down
12 changes: 12 additions & 0 deletions pact-core/Pact/Core/Builtin.hs
Original file line number Diff line number Diff line change
Expand Up @@ -190,6 +190,10 @@ data RawBuiltin
| RawMinutes
| RawDays
| RawCompose
| RawCreatePrincipal
| RawIsPrincipal
| RawTypeOfPrincipal
| RawValidatePrincipal
-- Namespaces
| RawNamespace
| RawDefineNamespace
Expand Down Expand Up @@ -319,6 +323,10 @@ rawBuiltinToText = \case
RawMinutes -> "minutes"
RawDays -> "days"
RawCompose -> "compose"
RawCreatePrincipal -> "create-principal"
RawIsPrincipal -> "is-principal"
RawTypeOfPrincipal -> "typeof-principal"
RawValidatePrincipal -> "validate-principal"
RawNamespace -> "namespace"
RawDefineNamespace -> "define-namespace"
RawDescribeNamespace -> "describe-namespace"
Expand Down Expand Up @@ -448,6 +456,10 @@ instance IsBuiltin RawBuiltin where
RawMinutes -> 1
RawDays -> 1
RawCompose -> 3
RawCreatePrincipal -> 1
RawIsPrincipal -> 1
RawTypeOfPrincipal -> 1
RawValidatePrincipal -> 2
RawNamespace -> 1
RawDefineNamespace -> 3
RawDescribeNamespace -> 1
Expand Down
17 changes: 15 additions & 2 deletions pact-core/Pact/Core/Guards.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,18 +4,22 @@

module Pact.Core.Guards
( PublicKeyText(..)
, renderPublicKeyText
, KeySetName(..)
, renderKeySetName
, Governance(..)
, KeySet(..)
, Guard(..)
, UserGuard(..)
, CapabilityGuard(..)
, KSPredicate(..)
, predicateToString
, ModuleGuard(..)
, CapGovRef(..)
)
where

import Data.String
import Data.Text(Text)
import qualified Data.Set as S
import Pact.Core.Pretty
Expand All @@ -28,12 +32,18 @@ newtype PublicKeyText = PublicKeyText { _pubKey :: Text }
instance Pretty PublicKeyText where
pretty (PublicKeyText t) = pretty t

renderPublicKeyText :: PublicKeyText -> Text
Copy link
Member

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 ?

Copy link
Contributor Author

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.

renderPublicKeyText = _pubKey

newtype KeySetName = KeySetName { _keysetName :: Text }
deriving (Eq,Ord,Show)

instance Pretty KeySetName where
pretty (KeySetName ks) = "'" <> pretty ks

renderKeySetName :: KeySetName -> Text
renderKeySetName = _keysetName

data Governance name
= KeyGov KeySetName
| CapGov (CapGovRef name)
Expand All @@ -58,12 +68,15 @@ data KSPredicate name
-- | CustomPredicate name
deriving (Eq, Show, Ord)

instance Pretty (KSPredicate name) where
pretty = \case
predicateToString :: IsString s => KSPredicate name -> s
predicateToString = \case
KeysAll -> "keys-all"
Keys2 -> "keys2"
KeysAny -> "keys-any"

instance Pretty (KSPredicate name) where
pretty = predicateToString

data KeySet name
= KeySet
{ _ksKeys :: !(S.Set PublicKeyText)
Expand Down
65 changes: 63 additions & 2 deletions pact-core/Pact/Core/IR/Eval/RawBuiltin.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Remove Pretty.renderText here and replace with renderQualName (fqnToQualName f)

-- TODO orig pact gets here ^^^^ a Name
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Todo still pending?

Copy link
Contributor Author

Choose a reason for hiding this comment

The 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 Names more thoroughly.

-- 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
Copy link
Member

Choose a reason for hiding this comment

The 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

Copy link
Contributor Author

Choose a reason for hiding this comment

The 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 MonadGas originally, but MonadGas was removed recently, so I changed that to Monad, while still keeping monadic syntax, so that (re)introducing gas would require less changes later on.

LMK if you'd nevertheless like to purify this function (for now?)

Copy link
Member

Choose a reason for hiding this comment

The 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
--------------------------------------------------
Expand Down Expand Up @@ -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
4 changes: 4 additions & 0 deletions pact-core/Pact/Core/Names.hs
Original file line number Diff line number Diff line change
Expand Up @@ -51,6 +51,7 @@ module Pact.Core.Names
, fqHash
, userTable
, DefPactId(..)
, renderDefPactId
) where

import Control.Lens
Expand Down Expand Up @@ -340,3 +341,6 @@ newtype DefPactId

instance Pretty DefPactId where
pretty (DefPactId p) = pretty p

renderDefPactId :: DefPactId -> Text
renderDefPactId (DefPactId t) = t
9 changes: 7 additions & 2 deletions pact-core/Pact/Core/PactValue.hs
Original file line number Diff line number Diff line change
Expand Up @@ -15,7 +15,9 @@ module Pact.Core.PactValue
, FQCapToken
, pattern PInteger
, pattern PDecimal
, pattern PString) where
, pattern PString
, pattern PBool
) where

import Control.Lens
import Control.Monad(zipWithM)
Expand Down Expand Up @@ -59,6 +61,9 @@ pattern PDecimal d = PLiteral (LDecimal d)
pattern PString :: Text -> PactValue
pattern PString s = PLiteral (LString s)

pattern PBool :: Bool -> PactValue
pattern PBool b = PLiteral (LBool b)

type FQCapToken = CapToken FullyQualifiedName PactValue

instance Pretty PactValue where
Expand Down Expand Up @@ -115,7 +120,7 @@ checkPvType ty = \case
_ -> Nothing
PCapToken _ -> Nothing
PTime _ -> case ty of
TyTime -> Just $ TyTime
TyTime -> Just TyTime
_ -> Nothing


Expand Down
Loading