From 08b28fe13a33698a5f188d3466b280c16b58a1a3 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Sun, 24 Sep 2023 18:40:44 -0400 Subject: [PATCH 1/5] stubs for db functions --- pact-core.cabal | 1 + pact-core/Pact/Core/Builtin.hs | 45 ++++++++++++++++++++ pact-core/Pact/Core/Capabilities.hs | 23 +++++++++- pact-core/Pact/Core/Compile.hs | 40 +++++++++++++++-- pact-core/Pact/Core/Errors.hs | 2 + pact-core/Pact/Core/IR/Eval/CEK.hs | 10 ++--- pact-core/Pact/Core/IR/Eval/RawBuiltin.hs | 14 ++++++ pact-core/Pact/Core/IR/Eval/Runtime/Types.hs | 27 +++--------- pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs | 7 +-- pact-core/Pact/Core/IR/Term.hs | 1 + pact-core/Pact/Core/Interpreter.hs | 44 +++++++++++++++++-- pact-core/Pact/Core/Persistence.hs | 4 ++ 12 files changed, 181 insertions(+), 37 deletions(-) diff --git a/pact-core.cabal b/pact-core.cabal index 73ddfd9b3..ffb3f0c74 100644 --- a/pact-core.cabal +++ b/pact-core.cabal @@ -105,6 +105,7 @@ library Pact.Core.Capabilities Pact.Core.ModRefs Pact.Core.Interpreter + Pact.Core.Environment -- Syntax modules Pact.Core.Syntax.ParseTree diff --git a/pact-core/Pact/Core/Builtin.hs b/pact-core/Pact/Core/Builtin.hs index 867d099a0..5c5efbc72 100644 --- a/pact-core/Pact/Core/Builtin.hs +++ b/pact-core/Pact/Core/Builtin.hs @@ -221,6 +221,23 @@ data RawBuiltin | RawB64Decode | RawStrToList | RawBind + -- Database functions + | RawCreateTable + | RawDescribeKeyset + | RawDescribeModule + | RawDescribeTable + | RawFoldDb + | RawInsert + | RawKeyLog + | RawKeys + | RawRead + | RawSelect + | RawUpdate + | RawWithDefaultRead + | RawWithRead + | RawWrite + -- | RawTxIds + -- | RawTxLog deriving (Eq, Show, Ord, Bounded, Enum) instance HasObjectOps RawBuiltin where @@ -302,6 +319,20 @@ rawBuiltinToText = \case RawB64Decode -> "base64-decode" RawStrToList -> "str-to-list" RawBind -> "bind" + RawCreateTable -> "create-table" + RawDescribeKeyset -> "describe-keyset" + RawDescribeModule -> "describe-module" + RawDescribeTable -> "describe-table" + RawFoldDb -> "fold-db" + RawInsert -> "insert" + RawKeyLog -> "keylog" + RawKeys -> "keys" + RawRead -> "read" + RawSelect -> "select" + RawUpdate -> "update" + RawWithDefaultRead -> "with-default-read" + RawWithRead -> "with-read" + RawWrite -> "write" instance IsBuiltin RawBuiltin where builtinName = NativeName . rawBuiltinToText @@ -380,6 +411,20 @@ instance IsBuiltin RawBuiltin where RawB64Decode -> 1 RawStrToList -> 1 RawBind -> 2 + RawCreateTable -> 1 + RawDescribeKeyset -> 1 + RawDescribeModule -> 1 + RawDescribeTable -> 1 + RawFoldDb -> 3 + RawInsert -> 3 + RawKeyLog -> 3 + RawKeys -> 1 + RawRead -> 2 + RawSelect -> 2 + RawUpdate -> 3 + RawWithDefaultRead -> 4 + RawWithRead -> 3 + RawWrite -> 3 rawBuiltinNames :: [Text] rawBuiltinNames = fmap rawBuiltinToText [minBound .. maxBound] diff --git a/pact-core/Pact/Core/Capabilities.hs b/pact-core/Pact/Core/Capabilities.hs index f1f667691..3e76f4857 100644 --- a/pact-core/Pact/Core/Capabilities.hs +++ b/pact-core/Pact/Core/Capabilities.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE InstanceSigs #-} module Pact.Core.Capabilities @@ -6,10 +7,14 @@ module Pact.Core.Capabilities , DefManagedMeta(..) , CapForm(..) , capFormName + , CapToken(..) + , CapSlot(..) + , FQCapToken ) where import Control.Lens - +import Pact.Core.Names +import Pact.Core.PactValue import Pact.Core.Pretty data DefManagedMeta name @@ -56,3 +61,19 @@ instance (Pretty name, Pretty e) => Pretty (CapForm name e) where CreateUserGuard name es -> parens ("create-user-guard" <+> parens (pretty name <+> hsep (pretty <$> es))) +-- | An acquired capability token +-- with the reference +data CapToken name + = CapToken + { _ctName :: name + , _ctArgs :: [PactValue] + } deriving (Show, Eq, Ord) + +-- +data CapSlot name + = CapSlot + { _csCap :: CapToken name + , _csComposed :: [CapToken name] + } deriving (Show, Eq) + +type FQCapToken = CapToken FullyQualifiedName diff --git a/pact-core/Pact/Core/Compile.hs b/pact-core/Pact/Core/Compile.hs index 61f311c8d..249324529 100644 --- a/pact-core/Pact/Core/Compile.hs +++ b/pact-core/Pact/Core/Compile.hs @@ -15,6 +15,7 @@ import Control.Monad.Except import Control.Monad import Data.Maybe(mapMaybe) import Data.Proxy +import Data.Foldable(traverse_) import Data.ByteString(ByteString) import qualified Data.Map.Strict as M import qualified Data.ByteString as B @@ -30,6 +31,7 @@ import Pact.Core.Pretty import Pact.Core.Type import Pact.Core.IR.Term import Pact.Core.Interpreter +import Pact.Core.Guards -- import qualified Pact.Core.Syntax.LexUtils as Lisp @@ -62,24 +64,54 @@ data CompileValue b deriving Show - compileProgram :: (HasCompileEnv b s m) => ByteString -> PactDb b SpanInfo - -> Interpreter b s m + -> Interpreter b m -> m [CompileValue b] compileProgram source pdb interp = do lexed <- liftEither (Lisp.lexer source) debugPrint DebugLexer lexed parsed <- liftEither (Lisp.parseProgram lexed) lo <- use loaded - traverse (runDesugarTopLevel Proxy pdb lo >=> interpretTopLevel pdb interp) parsed + traverse (go lo) parsed + where + go lo = + evalModuleGovernance pdb interp + >=> runDesugarTopLevel Proxy pdb lo + >=> interpretTopLevel pdb interp + +evalModuleGovernance + :: (HasCompileEnv b s m) + => PactDb b SpanInfo + -> Interpreter b m + -> Lisp.TopLevel SpanInfo + -> m (Lisp.TopLevel SpanInfo) +evalModuleGovernance pdb interp = \case + tl@(Lisp.TLModule m) -> liftIO (readModule pdb (Lisp._mName m)) >>= \case + Just (ModuleData md _) -> + case _mGovernance md of + KeyGov _ksn -> error "TODO: implement enforcing keyset names" + CapGov (Name n nk) -> case nk of + NTopLevel mn mh -> + use (loaded . loAllLoaded . at (FullyQualifiedName mn n mh)) >>= \case + Just (DCap d) -> + _interpret interp (_dcapTerm d) >>= \case + IPV{} -> pure tl + _ -> error "governance failure" + -- Todo: Definitely fixable with a GADT + _ -> error "invalid governance: not a defcap" + _ -> error "invariant failure: governance is not a fully qualified name" + Just (InterfaceData iface _) -> + throwError (PEExecutionError (CannotUpgradeInterface (_ifName iface)) (_ifInfo iface)) + Nothing -> pure tl + a -> pure a interpretTopLevel :: (HasCompileEnv b s m) => PactDb b SpanInfo - -> Interpreter b s m + -> Interpreter b m -> DesugarOutput b SpanInfo (TopLevel Name Type b SpanInfo) -> m (CompileValue b) interpretTopLevel pdb interp (DesugarOutput ds lo0 deps) = do diff --git a/pact-core/Pact/Core/Errors.hs b/pact-core/Pact/Core/Errors.hs index 2b68cfbf6..9a87bb210 100644 --- a/pact-core/Pact/Core/Errors.hs +++ b/pact-core/Pact/Core/Errors.hs @@ -284,6 +284,8 @@ data EvalError | DefIsNotClosure Text -- ^ Def is not a closure | NoSuchKeySet KeySetName + -- ^ No such keyset + | CannotUpgradeInterface ModuleName deriving Show instance Pretty EvalError where diff --git a/pact-core/Pact/Core/IR/Eval/CEK.hs b/pact-core/Pact/Core/IR/Eval/CEK.hs index 4d0ff56fb..d9bb87e58 100644 --- a/pact-core/Pact/Core/IR/Eval/CEK.hs +++ b/pact-core/Pact/Core/IR/Eval/CEK.hs @@ -211,7 +211,7 @@ evalCap => Cont b i m -> CEKErrorHandler b i m -> CEKEnv b i m - -> CapToken + -> FQCapToken -> EvalTerm b i -> m (EvalResult b i m) evalCap cont handler env ct@(CapToken fqn args) contbody = do @@ -284,7 +284,7 @@ requireCap :: MonadEval b i m => Cont b i m -> CEKErrorHandler b i m - -> CapToken + -> FQCapToken -> m (EvalResult b i m) requireCap cont handler ct = do caps <- useEvalState (esCaps.csSlots) @@ -297,7 +297,7 @@ composeCap :: (MonadEval b i m) => Cont b i m -> CEKErrorHandler b i m - -> CapToken + -> FQCapToken -> m (EvalResult b i m) composeCap cont handler ct@(CapToken fqn args) = do lookupFqName fqn >>= \case @@ -326,7 +326,7 @@ filterIndex i xs = [x | (x, i') <- zip xs [0..], i /= i'] installCap :: (MonadEval b i m) => Cont b i m -> CEKErrorHandler b i m - -> CapToken + -> FQCapToken -> m (EvalResult b i m) installCap cont handler ct@(CapToken fqn args) = do lookupFqName fqn >>= \case @@ -373,7 +373,7 @@ emitEvent :: MonadEval b i m => Cont b i m -> CEKErrorHandler b i m - -> CapToken + -> FQCapToken -> m (EvalResult b i m) emitEvent cont handler ct@(CapToken fqn _) = do let pactEvent = PactEvent ct (_fqModule fqn) (_fqHash fqn) diff --git a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs index f7b671c07..6356e31de 100644 --- a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs +++ b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs @@ -898,3 +898,17 @@ rawBuiltinLiftedRuntime f i = \case RawB64Decode -> coreB64Decode i (f RawB64Decode) RawStrToList -> strToList i (f RawStrToList) RawBind -> coreBind i (f RawBind) + RawCreateTable -> unimplemented + RawDescribeKeyset -> unimplemented + RawDescribeModule -> unimplemented + RawDescribeTable -> unimplemented + RawFoldDb -> unimplemented + RawInsert -> unimplemented + RawKeyLog -> unimplemented + RawKeys -> unimplemented + RawRead -> unimplemented + RawSelect -> unimplemented + RawUpdate -> unimplemented + RawWithDefaultRead -> unimplemented + RawWithRead -> unimplemented + RawWrite -> unimplemented diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs index d573f71c7..fb9c80669 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} @@ -102,6 +100,7 @@ import Pact.Core.Literal import Pact.Core.Type import Pact.Core.Persistence import Pact.Core.ModRefs +import Pact.Core.Capabilities import qualified Pact.Core.Pretty as P @@ -245,7 +244,6 @@ class Monad m => MonadGas m where logGas :: Text -> Gas -> m () chargeGas :: Gas -> m () - class (Monad m) => MonadEvalEnv b i m | m -> b, m -> i where readEnv :: m (EvalEnv b i m) @@ -312,21 +310,10 @@ data CondFrame b i | IfFrame (EvalTerm b i) (EvalTerm b i) deriving Show -data CapToken - = CapToken - { _ctName :: FullyQualifiedName - , _ctArgs :: [PactValue] - } deriving (Show, Eq, Ord) - -data CapSlot - = CapSlot - { _csCap :: CapToken - , _csComposed :: [CapToken] - } deriving (Show, Eq) data PactEvent b i = PactEvent - { _peToken :: CapToken + { _peToken :: CapToken FullyQualifiedName , _peModule :: ModuleName , _peModuleHash :: ModuleHash } deriving (Show, Eq) @@ -339,9 +326,9 @@ data ManagedCapType data ManagedCap = ManagedCap - { _mcCap :: CapToken + { _mcCap :: CapToken FullyQualifiedName -- ^ The token without the managed param - , _mcOriginalCap :: CapToken + , _mcOriginalCap :: CapToken FullyQualifiedName -- ^ The original, installed token , _mcManaged :: ManagedCapType -- ^ Managed capability type @@ -356,7 +343,7 @@ instance Ord ManagedCap where -- | The overall capability state data CapState = CapState - { _csSlots :: [CapSlot] + { _csSlots :: [CapSlot FullyQualifiedName] , _csManaged :: Set ManagedCap } deriving Show @@ -401,7 +388,7 @@ data Cont b i m data CEKErrorHandler b i m = CEKNoHandler - | CEKHandler (CEKEnv b i m) (EvalTerm b i) (Cont b i m) [CapSlot] (CEKErrorHandler b i m) + | CEKHandler (CEKEnv b i m) (EvalTerm b i) (Cont b i m) [CapSlot FullyQualifiedName] (CEKErrorHandler b i m) deriving Show data EvalEnv b i m @@ -410,7 +397,7 @@ data EvalEnv b i m , _eeGasModel :: GasEnv b , _eeLoaded :: CEKTLEnv b i , _eeMHashes :: Map ModuleName ModuleHash - , _eeMsgSigs :: Map PublicKeyText (Set CapToken) + , _eeMsgSigs :: Map PublicKeyText (Set (CapToken FullyQualifiedName)) , _eePactDb :: PactDb b i -- _cekGas :: IORef Gas -- , _cekEvalLog :: IORef (Maybe [(Text, Gas)]) diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs index ccd5a718d..47ca74c16 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs @@ -51,6 +51,7 @@ import Pact.Core.Type import Pact.Core.Errors import Pact.Core.IR.Eval.Runtime.Types import Pact.Core.Literal +import Pact.Core.Capabilities mkBuiltinFn :: (IsBuiltin b) @@ -73,7 +74,7 @@ cfFQN f = \case getAllStackCaps :: MonadEval b i m - => m (Set CapToken) + => m (Set FQCapToken) getAllStackCaps = do Set.fromList . concatMap capToList <$> useEvalState (esCaps . csSlots) where @@ -81,8 +82,8 @@ getAllStackCaps = do checkSigCaps :: MonadEval b i m - => Map PublicKeyText (Set CapToken) - -> m (Map PublicKeyText (Set CapToken)) + => Map PublicKeyText (Set FQCapToken) + -> m (Map PublicKeyText (Set FQCapToken)) checkSigCaps sigs = do granted <- getAllStackCaps pure $ M.filter (match granted) sigs diff --git a/pact-core/Pact/Core/IR/Term.hs b/pact-core/Pact/Core/IR/Term.hs index 21189292c..198552bfc 100644 --- a/pact-core/Pact/Core/IR/Term.hs +++ b/pact-core/Pact/Core/IR/Term.hs @@ -101,6 +101,7 @@ data Def name ty builtin info | DTable (DefTable name info) deriving (Show, Functor) + data Module name ty builtin info = Module { _mName :: ModuleName diff --git a/pact-core/Pact/Core/Interpreter.hs b/pact-core/Pact/Core/Interpreter.hs index c4d510227..e55e90971 100644 --- a/pact-core/Pact/Core/Interpreter.hs +++ b/pact-core/Pact/Core/Interpreter.hs @@ -1,18 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} module Pact.Core.Interpreter ( Interpreter(..) , InterpretValue(..) + , enforceKeyset )where +import Control.Lens +import Control.Monad.Except +import Data.Map.Strict(Map) +import Data.Set(Set) +import qualified Data.Map.Strict as M +import qualified Data.Set as S + import Pact.Core.Type import Pact.Core.IR.Term import Pact.Core.Info import Pact.Core.Names import Pact.Core.PactValue +import Pact.Core.Guards +import Pact.Core.Capabilities +import Pact.Core.Environment +import Pact.Core.Errors - -newtype Interpreter b s m - = Interpreter { - _interpret :: Term Name Type b SpanInfo -> m InterpretValue +newtype Interpreter b m + = Interpreter + { _interpret :: Term Name Type b SpanInfo -> m InterpretValue } data InterpretValue @@ -20,3 +32,27 @@ data InterpretValue | IPClosure | IPTable TableName deriving Show + +enforceKeyset + :: (MonadError (PactError i) m) + => EvalEnv b i + -> KeySet FullyQualifiedName + -> m Bool +enforceKeyset ee (KeySet kskeys ksPred) = do + let sigs = M.filterWithKey matchKey . view eeMsgSigs $ ee + runPred (M.size sigs) + where + matchKey k _ = k `elem` kskeys + atLeast t m = m >= t + -- elide pk + -- | T.length pk < 8 = pk + -- | otherwise = T.take 8 pk <> "..." + count = S.size kskeys + -- failed = "Keyset failure" + runPred matched = + case ksPred of + KeysAll -> run atLeast + KeysAny -> run (\_ m -> atLeast 1 m) + Keys2 -> run (\_ m -> atLeast 2 m) + where + run p = pure (p count matched) diff --git a/pact-core/Pact/Core/Persistence.hs b/pact-core/Pact/Core/Persistence.hs index 27318cda9..7672b30ec 100644 --- a/pact-core/Pact/Core/Persistence.hs +++ b/pact-core/Pact/Core/Persistence.hs @@ -123,6 +123,8 @@ data PactDb b i { _pdbPurity :: !Purity , _pdbRead :: forall k v. Domain k v b i -> k -> IO (Maybe v) , _pdbWrite :: forall k v. Domain k v b i -> k -> v -> IO () + , _pdbKeys :: forall k v. Domain k v b i -> IO [k] + , _pdbCreateUserTable :: forall k v. Domain k v b i -> TableName -> ModuleName -> IO () } makeClassy ''PactDb @@ -211,6 +213,8 @@ mockPactDb = do { _pdbPurity = PImpure , _pdbRead = read' refKs refMod refUsrTbl , _pdbWrite = write refKs refMod refUsrTbl + , _pdbKeys = undefined + , _pdbCreateUserTable = undefined } where read' From 08d567256c26d36d1d5c1ad9d4bc07f1827197e4 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Tue, 26 Sep 2023 12:00:28 -0400 Subject: [PATCH 2/5] moving values to local --- pact-core/Pact/Core/Environment.hs | 64 +++ pact-core/Pact/Core/IR/Eval/CEK.hs | 107 +++-- pact-core/Pact/Core/IR/Eval/RawBuiltin.hs | 384 +++++++++--------- pact-core/Pact/Core/IR/Eval/Runtime/Types.hs | 86 ++-- pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs | 10 +- pact-core/Pact/Core/Repl/Compile.hs | 29 +- pact-core/Pact/Core/Repl/Runtime.hs | 8 +- .../Pact/Core/Repl/Runtime/ReplBuiltin.hs | 63 +-- 8 files changed, 424 insertions(+), 327 deletions(-) create mode 100644 pact-core/Pact/Core/Environment.hs diff --git a/pact-core/Pact/Core/Environment.hs b/pact-core/Pact/Core/Environment.hs new file mode 100644 index 000000000..298f4b905 --- /dev/null +++ b/pact-core/Pact/Core/Environment.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE InstanceSigs #-} + + +module Pact.Core.Environment + ( EvalEnv(..) + , eeMsgSigs + , eePactDb + , eeHash +-- , eeWarning + , eeMsgBody + , PactState(..) + , psLoaded + ) where + +import Control.Lens +-- import Data.Text(Text) +import Data.Set(Set) +import Data.Map.Strict(Map) +-- import Data.IORef(IORef) + +import Pact.Core.Persistence +import Pact.Core.Capabilities +-- import Pact.Core.Gas +import Pact.Core.Guards +import Pact.Core.PactValue +import Pact.Core.Hash +-- import Pact.Core.Names + + +-- From pact +-- | All of the types included in our evaluation environment. +data EvalEnv b i + = EvalEnv + { _eeMsgSigs :: Map PublicKeyText (Set FQCapToken) + , _eePactDb :: PactDb b i + , _eeMsgBody :: EnvData PactValue + -- Todo: `PactWarning` + -- , _eeWarning :: IORef (Set Text) + , _eeHash :: Hash + -- _cekGas :: IORef Gas + -- , _cekEvalLog :: IORef (Maybe [(Text, Gas)]) + -- , _ckeData :: EnvData PactValue + } + +makeLenses ''EvalEnv + +newtype PactState b i + = PactState + { _psLoaded :: Loaded b i + } + +makeLenses ''PactState diff --git a/pact-core/Pact/Core/IR/Eval/CEK.hs b/pact-core/Pact/Core/IR/Eval/CEK.hs index d9bb87e58..74e467b94 100644 --- a/pact-core/Pact/Core/IR/Eval/CEK.hs +++ b/pact-core/Pact/Core/IR/Eval/CEK.hs @@ -42,19 +42,10 @@ import Pact.Core.IR.Eval.Runtime chargeNodeGas :: MonadEval b i m => NodeType -> m () -chargeNodeGas nt = do - gm <- view (eeGasModel . geGasModel . gmNodes) <$> readEnv - chargeGas (gm nt) +chargeNodeGas _nt = pure () + -- gm <- view (eeGasModel . geGasModel . gmNodes) <$> readEnv + -- chargeGas (gm nt) - --- chargeNative :: MonadEval b i m => b -> m () --- chargeNative native = do --- gm <- view (eeGasModel . geGasModel . gmNatives) <$> readEnv --- chargeGas (gm native) - --- Todo: exception handling? do we want labels --- Todo: `traverse` usage should be perf tested. --- It might be worth making `Arg` frames incremental, as opposed to a traverse call eval :: forall b i m. (MonadEval b i m) => CEKEnv b i m @@ -72,7 +63,7 @@ evalCEK evalCEK cont handler env (Var n info) = do chargeNodeGas VarNode case _nKind n of - NBound i -> case RAList.lookup env i of + NBound i -> case RAList.lookup (view ceLocal env) i of -- Todo: module ref anns here Just v -> returnCEKValue cont handler v Nothing -> failInvariant' ("unbound identifier" <> T.pack (show n)) info @@ -81,10 +72,10 @@ evalCEK cont handler env (Var n info) = do let fqn = FullyQualifiedName mname (_nName n) mh lookupFqName fqn >>= \case Just (Dfun d) -> do - dfunClo <- mkDefunClosure d + dfunClo <- mkDefunClosure d env returnCEKValue cont handler dfunClo Just (DConst d) -> - evalCEK cont handler mempty (_dcTerm d) + evalCEK cont handler (set ceLocal mempty env) (_dcTerm d) Just (DTable d) -> let (ResolvedTable sc) = _dtSchema d tbl = VTable (TableName (_dtName d)) mname mh sc @@ -110,10 +101,10 @@ evalCEK cont handler env (Lam li args body info) = do chargeNodeGas LamNode let clo = VLamClosure (LamClosure li (_argType <$> args) (NE.length args) body Nothing env info) returnCEKValue cont handler clo -evalCEK cont handler _env (Builtin b i) = do +evalCEK cont handler env (Builtin b i) = do chargeNodeGas BuiltinNode - builtins <- view eeBuiltins <$> readEnv - returnCEKValue cont handler (VNative (builtins i b)) + let builtins = view ceBuiltins env + returnCEKValue cont handler (VNative (builtins i b env)) evalCEK cont handler env (Sequence e1 e2 _) = do chargeNodeGas SeqNode evalCEK (SeqC env e2 cont) handler env e1 @@ -142,7 +133,7 @@ evalCEK cont handler env (CapabilityForm cf _) = do cont' = CapInvokeC env xs [] capFrame cont in evalCEK cont' handler env x ComposeCapability _ args -> case args of - [] -> composeCap cont handler (CapToken fqn []) + [] -> composeCap cont handler env (CapToken fqn []) x:xs -> let capFrame = ComposeCapFrame fqn cont' = CapInvokeC env xs [] capFrame cont @@ -190,10 +181,11 @@ evalCEK _ handler _ (Error e _) = mkDefunClosure :: (MonadEval b i m) => Defun Name Type b i + -> CEKEnv b i m -> m (CEKValue b i m) -mkDefunClosure d = case _dfunTerm d of +mkDefunClosure d e = case _dfunTerm d of Lam li args body i -> - pure (VDefClosure (Closure li (_argType <$> args) (NE.length args) body (_dfunRType d) i)) + pure (VDefClosure (Closure li (_argType <$> args) (NE.length args) body (_dfunRType d) e i)) _ -> throwExecutionError (_dfunInfo d) (DefIsNotClosure (_dfunName d)) @@ -241,7 +233,7 @@ evalCap cont handler env ct@(CapToken fqn args) contbody = do result <- evaluate (_dfunTerm dfun) pv mparam let mcM = ManagedParam mpfqn result managedIx esCaps . csManaged %%= S.union (S.singleton (set mcManaged mcM managedCap)) - evalCEK cont' handler env' capBody + evalCEK cont' handler (set ceLocal env' env) capBody _ -> error "not a defun" _ -> error "incorrect cap type" Nothing -> do @@ -254,10 +246,10 @@ evalCap cont handler env ct@(CapToken fqn args) contbody = do else do let newManaged = AutoManaged True esCaps . csManaged %%= S.union (S.singleton (set mcManaged newManaged managedCap)) - evalCEK cont' handler env' capBody + evalCEK cont' handler (set ceLocal env' env) capBody _ -> error "incorrect cap type" Just DefEvent -> error "defEvent" - Nothing -> evalCEK cont' handler env' capBody + Nothing -> evalCEK cont' handler (set ceLocal env' env) capBody Just {} -> error "was not defcap, invariant violated" Nothing -> error "No such def" where @@ -266,7 +258,7 @@ evalCap cont handler env ct@(CapToken fqn args) contbody = do -- Todo: `applyLam` here gives suboptimal errors -- Todo: this completely violates our "step" semantics. -- This should be its own frame - let clo = Closure li (_argType <$> lamargs) (NE.length lamargs) body Nothing i + let clo = Closure li (_argType <$> lamargs) (NE.length lamargs) body Nothing env i res <- applyLam (C clo) [VPactValue managed, VPactValue value] Mt CEKNoHandler case res of EvalValue out -> enforcePactValue out @@ -297,15 +289,16 @@ composeCap :: (MonadEval b i m) => Cont b i m -> CEKErrorHandler b i m + -> CEKEnv b i m -> FQCapToken -> m (EvalResult b i m) -composeCap cont handler ct@(CapToken fqn args) = do +composeCap cont handler env ct@(CapToken fqn args) = do lookupFqName fqn >>= \case Just (DCap d) -> do (esCaps . csSlots) %%= (CapSlot ct []:) (env', capBody) <- applyCapBody (_dcapTerm d) let cont' = CapPopC PopCapComposed cont - evalCEK cont' handler env' capBody + evalCEK cont' handler (set ceLocal env' env) capBody -- todo: this error loc is _not_ good. Need to propagate `i` here, maybe in the stack Just d -> throwExecutionError (defInfo d) $ InvalidDefKind (defKind d) "in compose-capability" @@ -460,7 +453,7 @@ returnCEKValue (CapInvokeC env terms pvs cf cont) handler v = do RequireCapFrame fqn -> requireCap cont handler (CapToken fqn (reverse (pv:pvs))) ComposeCapFrame fqn -> - composeCap cont handler (CapToken fqn (reverse (pv:pvs))) + composeCap cont handler env (CapToken fqn (reverse (pv:pvs))) InstallCapFrame fqn -> installCap cont handler (CapToken fqn (reverse (pv:pvs))) EmitEventFrame fqn -> @@ -502,14 +495,14 @@ returnCEKValue (ObjC env currfield fs vs cont) handler v = do -- Todo: note over here we might want to typecheck -- Todo: inline the variable lookup instead of calling EvalCEK directly, -- as we can provide a better error message this way. -returnCEKValue (DynInvokeC env fn cont) handler v = case v of - VModRef mn -> do +returnCEKValue (DynInvokeC _env _fn _cont) _handler v = case v of + VModRef _mn -> error "todo: stubbed while refactoring env" -- Todo: for when persistence is implemented -- here is where we would incur module loading - readEnv >>= \e -> case view (eeMHashes . at (_mrModule mn)) e of - Just mh -> - evalCEK cont handler env (Var (Name fn (NTopLevel (_mrModule mn) mh)) def) - Nothing -> failInvariant "No such module" + -- readEnv >>= \e -> case view (eeMHashes . at (_mrModule mn)) e of + -- Just mh -> + -- evalCEK cont handler env (Var (Name fn (NTopLevel (_mrModule mn) mh)) def) + -- Nothing -> failInvariant "No such module" _ -> failInvariant "Not a modref" returnCEKValue (StackPopC mty cont) handler v = do v' <- (`maybeTCType` mty) =<< enforcePactValue v @@ -524,13 +517,14 @@ applyLam -> Cont b i m -> CEKErrorHandler b i m -> m (EvalResult b i m) -applyLam (C (Closure li cloargs arity term mty cloi)) args cont handler +applyLam (C (Closure li cloargs arity term mty env cloi)) args cont handler | arity == argLen = do args' <- traverse enforcePactValue args tcArgs <- zipWithM (\arg ty -> VPactValue <$> maybeTCType arg ty) args' (NE.toList cloargs) esStack %%= (StackFrame li :) let cont' = StackPopC mty cont - evalCEK cont' handler (RAList.fromList (reverse tcArgs)) term + varEnv = RAList.fromList (reverse tcArgs) + evalCEK cont' handler (set ceLocal varEnv env) term | argLen > arity = error "Closure applied to too many arguments" | otherwise = apply' mempty (NE.toList cloargs) args where @@ -541,19 +535,22 @@ applyLam (C (Closure li cloargs arity term mty cloi)) args cont handler apply' (RAList.cons (VPactValue x') e) tys xs apply' e [] [] = do esStack %%= (StackFrame li :) - evalCEK cont handler e term - apply' e (ty:tys) [] = - returnCEKValue cont handler (VPartialClosure (PartialClosure li (ty :| tys) (length tys + 1) term mty e cloi)) + evalCEK cont handler (set ceLocal e env) term + apply' e (ty:tys) [] = do + let env' = set ceLocal e env + pclo = PartialClosure li (ty :| tys) (length tys + 1) term mty env' cloi + returnCEKValue cont handler (VPartialClosure pclo) apply' _ [] _ = error "Applying too many arguments to function" applyLam (LC (LamClosure li cloargs arity term mty env cloi)) args cont handler | arity == argLen = do esStack %%= (StackFrame li :) + let locals = view ceLocal env let cont' = StackPopC mty cont - env' = foldl' (flip RAList.cons) env args - evalCEK cont' handler env' term + locals' = foldl' (flip RAList.cons) locals args + evalCEK cont' handler (set ceLocal locals' env) term | argLen > arity = error "Closure applied to too many arguments" - | otherwise = apply' env (NE.toList cloargs) args + | otherwise = apply' (view ceLocal env) (NE.toList cloargs) args where argLen = length args -- Todo: runtime TC here @@ -562,13 +559,14 @@ applyLam (LC (LamClosure li cloargs arity term mty env cloi)) args cont handler apply' (RAList.cons (VPactValue x') e) tys xs apply' e [] [] = do esStack %%= (StackFrame li :) - evalCEK cont handler e term + evalCEK cont handler (set ceLocal e env) term apply' e (ty:tys) [] = - returnCEKValue cont handler (VPartialClosure (PartialClosure li (ty :| tys) (length tys + 1) term mty e cloi)) + returnCEKValue cont handler + (VPartialClosure (PartialClosure li (ty :| tys) (length tys + 1) term mty (set ceLocal e env) cloi)) apply' _ [] _ = error "Applying too many arguments to function" applyLam (PC (PartialClosure li argtys _ term mty env i)) args cont handler = - apply' env (NE.toList argtys) args + apply' (view ceLocal env) (NE.toList argtys) args where apply' e (ty:tys) (x:xs) = do x' <- (`maybeTCType` ty) =<< enforcePactValue x @@ -576,30 +574,31 @@ applyLam (PC (PartialClosure li argtys _ term mty env i)) args cont handler = apply' e [] [] = do let cont' = StackPopC mty cont esStack %%= (StackFrame li :) - evalCEK cont' handler e term - apply' e (ty:tys) [] = - returnCEKValue cont handler (VPartialClosure (PartialClosure li (ty :| tys) (length tys + 1) term mty e i)) + evalCEK cont' handler (set ceLocal e env) term + apply' e (ty:tys) [] = do + let pclo = PartialClosure li (ty :| tys) (length tys + 1) term mty (set ceLocal e env) i + returnCEKValue cont handler (VPartialClosure pclo) apply' _ [] _ = error "Applying too many arguments to partial function" -applyLam (N (NativeFn b fn arity i)) args cont handler - | arity == argLen = fn cont handler args +applyLam (N (NativeFn b env fn arity i)) args cont handler + | arity == argLen = fn i b cont handler env args | argLen > arity = error "Applying too many args to native" | otherwise = apply' arity [] args where argLen = length args apply' !a pa (x:xs) = apply' (a - 1) (x:pa) xs apply' !a pa [] = - returnCEKValue cont handler (VPartialNative (PartialNativeFn b fn a pa i)) + returnCEKValue cont handler (VPartialNative (PartialNativeFn b env fn a pa i)) -applyLam (PN (PartialNativeFn b fn arity pArgs i)) args cont handler - | arity == argLen = fn cont handler (reverse pArgs ++ args) +applyLam (PN (PartialNativeFn b env fn arity pArgs i)) args cont handler + | arity == argLen = fn i b cont handler env (reverse pArgs ++ args) | argLen > arity = error "Applying too many args to native partial" | otherwise = apply' arity [] args where argLen = length args apply' !a pa (x:xs) = apply' (a - 1) (x:pa) xs apply' !a pa [] = - returnCEKValue cont handler (VPartialNative (PartialNativeFn b fn a pa i)) + returnCEKValue cont handler (VPartialNative (PartialNativeFn b env fn a pa i)) failInvariant :: MonadEval b i m => Text -> m a diff --git a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs index 6356e31de..de06ec7bf 100644 --- a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs +++ b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs @@ -9,8 +9,8 @@ {-# LANGUAGE ConstraintKinds #-} module Pact.Core.IR.Eval.RawBuiltin - ( rawBuiltinLiftedRuntime - , rawBuiltinRuntime ) where + ( rawBuiltinRuntime + , rawBuiltinEnv ) where -- | -- Module : Pact.Core.Eval.RawBuiltin @@ -45,6 +45,7 @@ import Pact.Core.Guards import Pact.Core.Type(Arg(..)) import Pact.Core.PactValue import Pact.Core.Persistence +import Pact.Core.Environment import Pact.Core.IR.Term import Pact.Core.IR.Eval.Runtime @@ -56,8 +57,8 @@ import Pact.Core.IR.Eval.CEK ---------------------------------------------------------------------- -- -- Todo: runtime error -unaryIntFn :: (IsBuiltin b, MonadEval b i m) => (Integer -> Integer) -> i -> b -> NativeFn b i m -unaryIntFn op info b = mkBuiltinFn info b \cont handler -> \case +unaryIntFn :: (IsBuiltin b, MonadEval b i m) => (Integer -> Integer) -> NativeFunction b i m +unaryIntFn op = \info b cont handler _env -> \case [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LInteger (op i))) args -> argsError info b args {-# INLINE unaryIntFn #-} @@ -65,16 +66,14 @@ unaryIntFn op info b = mkBuiltinFn info b \cont handler -> \case binaryIntFn :: (IsBuiltin b, MonadEval b i m) => (Integer -> Integer -> Integer) - -> i - -> b - -> NativeFn b i m -binaryIntFn op info b = mkBuiltinFn info b \cont handler -> \case + -> NativeFunction b i m +binaryIntFn op = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (op i i'))) args -> argsError info b args {-# INLINE binaryIntFn #-} -roundingFn :: (IsBuiltin b, MonadEval b i m) => (Rational -> Integer) -> i -> b -> NativeFn b i m -roundingFn op info b = mkBuiltinFn info b \cont handler -> \case +roundingFn :: (IsBuiltin b, MonadEval b i m) => (Rational -> Integer) -> NativeFunction b i m +roundingFn op = \info b cont handler _env -> \case [VLiteral (LDecimal i)] -> returnCEKValue cont handler (VLiteral (LInteger (truncate (roundTo' op 0 i)))) args -> argsError info b args {-# INLINE roundingFn #-} @@ -82,8 +81,8 @@ roundingFn op info b = mkBuiltinFn info b \cont handler -> \case --------------------------------- -- Arithmetic Ops ------------------------------ -rawAdd :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawAdd info b = mkBuiltinFn info b \cont handler -> \case +rawAdd :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawAdd = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (i + i'))) [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (i + i'))) [VLiteral (LString i), VLiteral (LString i')] -> @@ -94,20 +93,20 @@ rawAdd info b = mkBuiltinFn info b \cont handler -> \case [VList l, VList r] -> returnCEKValue cont handler (VList (l <> r)) args -> argsError info b args -rawSub :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawSub info b = mkBuiltinFn info b \cont handler -> \case +rawSub :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawSub = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (i - i'))) [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (i - i'))) args -> argsError info b args -rawMul :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawMul info b = mkBuiltinFn info b \cont handler -> \case +rawMul :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawMul = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (i * i'))) [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LDecimal (i * i'))) args -> argsError info b args -rawPow :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawPow info b = mkBuiltinFn info b \cont handler -> \case +rawPow :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawPow = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> do when (i' < 0) $ throwExecutionError info (ArithmeticException "negative exponent in integer power") returnCEKValue cont handler (VLiteral (LInteger (i ^ i'))) @@ -117,8 +116,8 @@ rawPow info b = mkBuiltinFn info b \cont handler -> \case returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) args -> argsError info b args -rawLogBase :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawLogBase info b = mkBuiltinFn info b \cont handler -> \case +rawLogBase :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawLogBase = \info b cont handler _env -> \case [VLiteral (LInteger base), VLiteral (LInteger n)] -> do when (base < 0 || n <= 0) $ throwExecutionError info (ArithmeticException "Illegal log base") let base' = fromIntegral base :: Double @@ -134,8 +133,8 @@ rawLogBase info b = mkBuiltinFn info b \cont handler -> \case returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) args -> argsError info b args -rawDiv :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawDiv info b = mkBuiltinFn info b \cont handler -> \case +rawDiv :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawDiv = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> if i' == 0 then throwExecutionError info (ArithmeticException "div by zero") else returnCEKValue cont handler (VLiteral (LInteger (div i i'))) @@ -144,81 +143,81 @@ rawDiv info b = mkBuiltinFn info b \cont handler -> \case else returnCEKValue cont handler (VLiteral (LDecimal (i / i'))) args -> argsError info b args -rawNegate :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawNegate info b = mkBuiltinFn info b \cont handler -> \case +rawNegate :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawNegate = \info b cont handler env -> \case [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LInteger (negate i))) [VLiteral (LDecimal i)] -> returnCEKValue cont handler (VLiteral (LDecimal (negate i))) args -> argsError info b args -rawEq :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawEq info b = mkBuiltinFn info b \cont handler -> \case +rawEq :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawEq = \info b cont handler _env -> \case [VPactValue pv, VPactValue pv'] -> returnCEKValue cont handler (VBool (pv == pv')) args -> argsError info b args -modInt :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +modInt :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m modInt = binaryIntFn mod -rawNeq :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawNeq info b = mkBuiltinFn info b \cont handler -> \case +rawNeq :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawNeq = \info b cont handler _env -> \case [VPactValue pv, VPactValue pv'] -> returnCEKValue cont handler (VBool (pv /= pv')) args -> argsError info b args -rawGt :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawGt info b = mkBuiltinFn info b \cont handler -> \case +rawGt :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawGt = \info b cont handler _dcNameenv -> \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i > i'))) [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i > i'))) [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i > i'))) args -> argsError info b args -rawLt :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawLt info b = mkBuiltinFn info b \cont handler -> \case +rawLt :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawLt = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i < i'))) [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i < i'))) [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i < i'))) args -> argsError info b args -rawGeq :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawGeq info b = mkBuiltinFn info b \cont handler -> \case +rawGeq :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawGeq = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i >= i'))) [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i >= i'))) [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i >= i'))) args -> argsError info b args -rawLeq :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawLeq info b = mkBuiltinFn info b \cont handler -> \case +rawLeq :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawLeq = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LBool (i <= i'))) [VLiteral (LDecimal i), VLiteral (LDecimal i')] -> returnCEKValue cont handler (VLiteral (LBool (i <= i'))) [VLiteral (LString i), VLiteral (LString i')] -> returnCEKValue cont handler (VLiteral (LBool (i <= i'))) args -> argsError info b args -bitAndInt :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +bitAndInt :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m bitAndInt = binaryIntFn (.&.) -bitOrInt :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +bitOrInt :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m bitOrInt = binaryIntFn (.|.) -bitComplementInt :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +bitComplementInt :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m bitComplementInt = unaryIntFn complement -bitXorInt :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +bitXorInt :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m bitXorInt = binaryIntFn xor -bitShiftInt :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +bitShiftInt :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m bitShiftInt = binaryIntFn (\i s -> shift i (fromIntegral s)) -rawAbs :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawAbs info b = mkBuiltinFn info b \cont handler -> \case +rawAbs :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawAbs = \info b cont handler env -> \case [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LInteger (abs i))) [VLiteral (LDecimal e)] -> do returnCEKValue cont handler (VLiteral (LDecimal (abs e))) args -> argsError info b args -rawExp :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawExp info b = mkBuiltinFn info b \cont handler -> \case +rawExp :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawExp = \info b cont handler _env -> \case [VLiteral (LInteger i)] -> do let result = exp (fromIntegral i) guardNanOrInf info result @@ -229,8 +228,8 @@ rawExp info b = mkBuiltinFn info b \cont handler -> \case returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) args -> argsError info b args -rawLn :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawLn info b = mkBuiltinFn info b \cont handler -> \case +rawLn :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawLn = \info b cont handler _env -> \case [VLiteral (LInteger i)] -> do let result = log (fromIntegral i) guardNanOrInf info result @@ -241,8 +240,8 @@ rawLn info b = mkBuiltinFn info b \cont handler -> \case returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) args -> argsError info b args -rawSqrt :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawSqrt info b = mkBuiltinFn info b \cont handler -> \case +rawSqrt :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawSqrt = \info b cont handler _env -> \case [VLiteral (LInteger i)] -> do when (i < 0) $ throwExecutionError info (ArithmeticException "Square root must be non-negative") let result = sqrt (fromIntegral i) @@ -256,8 +255,8 @@ rawSqrt info b = mkBuiltinFn info b \cont handler -> \case args -> argsError info b args -- Todo: fix all show instances -rawShow :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawShow info b = mkBuiltinFn info b \cont handler -> \case +rawShow :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawShow = \info b cont handler _env -> \case [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LString (T.pack (show i)))) [VLiteral (LDecimal i)] -> @@ -270,8 +269,8 @@ rawShow info b = mkBuiltinFn info b \cont handler -> \case returnCEKValue cont handler (VLiteral (LString "()")) args -> argsError info b args -rawContains :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawContains info b = mkBuiltinFn info b \cont handler -> \case +rawContains :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawContains = \info b cont handler _env -> \case [VString f, VObject o] -> returnCEKValue cont handler (VBool (M.member (Field f) o)) [VString s, VString s'] -> @@ -280,8 +279,8 @@ rawContains info b = mkBuiltinFn info b \cont handler -> \case returnCEKValue cont handler (VBool (v `V.elem` vli)) args -> argsError info b args -rawSort :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawSort info b = mkBuiltinFn info b \cont handler -> \case +rawSort :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawSort = \info b cont handler _env -> \case [VList vli] | V.null vli -> returnCEKValue cont handler (VList mempty) | otherwise -> do @@ -292,8 +291,8 @@ rawSort info b = mkBuiltinFn info b \cont handler -> \case returnCEKValue cont handler (VList vli') args -> argsError info b args -rawRemove :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawRemove info b = mkBuiltinFn info b \cont handler -> \case +rawRemove :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawRemove = \info b cont handler _env -> \case [VString s, VObject o] -> returnCEKValue cont handler (VObject (M.delete (Field s) o)) args -> argsError info b args @@ -307,8 +306,8 @@ asObject info b = \case PObject o -> pure o arg -> argsError info b [VPactValue arg] -rawSortObject :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawSortObject info b = mkBuiltinFn info b \cont handler -> \case +rawSortObject :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawSortObject = \info b cont handler _env -> \case [VList fields, VList objs] | V.null fields -> returnCEKValue cont handler (VList objs) | V.null objs -> returnCEKValue cont handler (VList objs) @@ -345,20 +344,20 @@ dec2F = fromRational . toRational f2Dec :: Double -> Decimal f2Dec = fromRational . toRational -roundDec :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +roundDec :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m roundDec = roundingFn round -floorDec :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +floorDec :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m floorDec = roundingFn floor -ceilingDec :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +ceilingDec :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m ceilingDec = roundingFn ceiling --------------------------- -- bool ops --------------------------- -notBool :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -notBool info b = mkBuiltinFn info b \cont handler -> \case +notBool :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +notBool = \info b cont handler _env -> \case [VLiteral (LBool i)] -> returnCEKValue cont handler (VLiteral (LBool (not i))) args -> argsError info b args @@ -366,8 +365,8 @@ notBool info b = mkBuiltinFn info b \cont handler -> \case -- string ops --------------------------- -rawTake :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawTake info b = mkBuiltinFn info b \cont handler -> \case +rawTake :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawTake = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LString t)] | i >= 0 -> do let clamp = min (fromIntegral i) (T.length t) @@ -384,8 +383,8 @@ rawTake info b = mkBuiltinFn info b \cont handler -> \case returnCEKValue cont handler (VList (V.drop clamp li)) args -> argsError info b args -rawDrop :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawDrop info b = mkBuiltinFn info b \cont handler -> \case +rawDrop :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawDrop = \info b cont handler _env -> \case [VLiteral (LInteger i), VLiteral (LString t)] | i >= 0 -> do let clamp = min (fromIntegral i) (T.length t) @@ -402,15 +401,15 @@ rawDrop info b = mkBuiltinFn info b \cont handler -> \case returnCEKValue cont handler (VList (V.take clamp li)) args -> argsError info b args -rawLength :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawLength info b = mkBuiltinFn info b \cont handler -> \case +rawLength :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawLength = \info b cont handler _env -> \case [VLiteral (LString t)] -> do returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (T.length t)))) [VList li] -> returnCEKValue cont handler (VLiteral (LInteger (fromIntegral (V.length li)))) args -> argsError info b args -rawReverse :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -rawReverse info b = mkBuiltinFn info b \cont handler -> \case +rawReverse :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +rawReverse = \info b cont handler _env -> \case [VList li] -> returnCEKValue cont handler (VList (V.reverse li)) [VLiteral (LString t)] -> do @@ -418,21 +417,21 @@ rawReverse info b = mkBuiltinFn info b \cont handler -> \case args -> argsError info b args -- showStr :: (IsBuiltin b, MonadEval b i m) => b -> NativeFn b i m --- showStr info b = mkBuiltinFn info b \cont handler -> \case +-- showStr = \info b cont handler env -> \case -- [VLiteral (LString t)] -> do -- let out = "\"" <> t <> "\"" -- returnCEKValue cont handler (VLiteral (LString out)) -- _ -> failInvariant "showStr" -coreConcat :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreConcat info b = mkBuiltinFn info b \cont handler -> \case +coreConcat :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreConcat = \info b cont handler _env -> \case [VList li] -> do li' <- traverse (asString info b) li returnCEKValue cont handler (VString (T.concat (V.toList li'))) args -> argsError info b args -strToList :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -strToList info b = mkBuiltinFn info b \cont handler -> \case +strToList :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +strToList = \info b cont handler _env -> \case [VLiteral (LString s)] -> do let v = VList (V.fromList (PLiteral . LString . T.singleton <$> T.unpack s)) returnCEKValue cont handler v @@ -443,17 +442,17 @@ strToList info b = mkBuiltinFn info b \cont handler -> \case --------------------------- -- eqUnit :: (IsBuiltin b, MonadEval b i m) => b -> NativeFn b i m --- eqUnit info b = mkBuiltinFn info b \cont handler -> \case +-- eqUnit = \info b cont handler env -> \case -- [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool True)) -- _ -> failInvariant "eqUnit" -- neqUnit :: (IsBuiltin b, MonadEval b i m) => b -> NativeFn b i m --- neqUnit info b = mkBuiltinFn info b \cont handler -> \case +-- neqUnit = \info b cont handler env -> \case -- [VLiteral LUnit, VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LBool False)) -- _ -> failInvariant "neqUnit" -- showUnit :: (IsBuiltin b, MonadEval b i m) => b -> NativeFn b i m --- showUnit info b = mkBuiltinFn info b \cont handler -> \case +-- showUnit = \info b cont handler env -> \case -- [VLiteral LUnit] -> returnCEKValue cont handler (VLiteral (LString "()")) -- _ -> failInvariant "showUnit" @@ -479,8 +478,8 @@ strToList info b = mkBuiltinFn info b \cont handler -> \case -- asBool (VLiteral (LBool b)) = pure b -- asBool _ = failInvariant "asBool" -zipList :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -zipList info b = mkBuiltinFn info b \cont handler -> \case +zipList :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +zipList = \info b cont handler _env -> \case [VClosure clo, VList l, VList r] -> zip' (V.toList l) (V.toList r) [] where zip' (x:xs) (y:ys) acc = unsafeApplyTwo clo (VPactValue x) (VPactValue y) >>= \case @@ -489,8 +488,8 @@ zipList info b = mkBuiltinFn info b \cont handler -> \case zip' _ _ acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) args -> argsError info b args -coreMap :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreMap info b = mkBuiltinFn info b \cont handler -> \case +coreMap :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreMap = \info b cont handler _env -> \case [VClosure fn, VList li] -> map' (V.toList li) [] where map' (x:xs) acc = unsafeApplyOne fn (VPactValue x) >>= \case @@ -499,8 +498,8 @@ coreMap info b = mkBuiltinFn info b \cont handler -> \case map' _ acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) args -> argsError info b args -coreFilter :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreFilter info b = mkBuiltinFn info b \cont handler -> \case +coreFilter :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreFilter = \info b cont handler _env -> \case [VClosure fn, VList li] -> filter' (V.toList li) [] where filter' (x:xs) acc = unsafeApplyOne fn (VPactValue x) >>= \case @@ -512,8 +511,8 @@ coreFilter info b = mkBuiltinFn info b \cont handler -> \case filter' [] acc = returnCEKValue cont handler (VList (V.fromList (reverse acc))) args -> argsError info b args -coreFold :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreFold info b = mkBuiltinFn info b \cont handler -> \case +coreFold :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreFold = \info b cont handler _env -> \case [VClosure fn, initElem, VList li] -> fold' initElem (V.toList li) where @@ -523,8 +522,8 @@ coreFold info b = mkBuiltinFn info b \cont handler -> \case fold' e [] = returnCEKValue cont handler e args -> argsError info b args -coreEnumerate :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreEnumerate info b = mkBuiltinFn info b \cont handler -> \case +coreEnumerate :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreEnumerate = \info b cont handler _env -> \case [VLiteral (LInteger from), VLiteral (LInteger to)] -> do v <- createEnumerateList info from to (if from > to then -1 else 1) returnCEKValue cont handler (VList (PLiteral . LInteger <$> v)) @@ -551,28 +550,28 @@ createEnumerateList info from to inc step = succ (abs (from - to) `div` abs inc) in pure $ V.enumFromStepN from inc (fromIntegral step) -coreEnumerateStepN :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreEnumerateStepN info b = mkBuiltinFn info b \cont handler -> \case +coreEnumerateStepN :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreEnumerateStepN = \info b cont handler _env -> \case [VLiteral (LInteger from), VLiteral (LInteger to), VLiteral (LInteger inc)] -> do v <- createEnumerateList info from to inc returnCEKValue cont handler (VList (PLiteral . LInteger <$> v)) args -> argsError info b args -- concatList :: (IsBuiltin b, MonadEval b i m) => b -> NativeFn b i m --- concatList info b = mkBuiltinFn info b \cont handler -> \case +-- concatList = \info b cont handler env -> \case -- [VList li] -> do -- li' <- traverse asList li -- returnCEKValue cont handler (VList (V.concat (V.toList li'))) -- _ -> failInvariant "takeList" -makeList :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -makeList info b = mkBuiltinFn info b \cont handler -> \case +makeList :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +makeList = \info b cont handler _env -> \case [VLiteral (LInteger i), VPactValue v] -> do returnCEKValue cont handler (VList (V.fromList (replicate (fromIntegral i) v))) args -> argsError info b args -coreAccess :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreAccess info b = mkBuiltinFn info b \cont handler -> \case +coreAccess :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreAccess = \info b cont handler _env -> \case [VLiteral (LInteger i), VList vec] -> case vec V.!? fromIntegral i of Just v -> returnCEKValue cont handler (VPactValue v) @@ -589,14 +588,14 @@ coreAccess info b = mkBuiltinFn info b \cont handler -> \case -- try-related ops ----------------------------------- -coreEnforce :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreEnforce info b = mkBuiltinFn info b \cont handler -> \case +coreEnforce :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreEnforce = \info b cont handler _env -> \case [VLiteral (LBool b'), VLiteral (LString s)] -> if b' then returnCEKValue cont handler (VLiteral LUnit) else returnCEK cont handler (VError s) args -> argsError info b args --- coreEnforceOne :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +-- coreEnforceOne :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -- coreEnforceOne info b = mkBuiltinFn info b \case -- [VList v, VLiteral (LString msg)] -> -- enforceFail msg (V.toList v) @@ -617,7 +616,7 @@ coreEnforce info b = mkBuiltinFn info b \cont handler -> \case -- readError field expected = -- "invalid value at field " <> field <> " expected: " <> expected --- coreReadInteger :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +-- coreReadInteger :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -- coreReadInteger info b = mkBuiltinFn info b \case -- [VLiteral (LString s)] -> -- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of @@ -627,7 +626,7 @@ coreEnforce info b = mkBuiltinFn info b \cont handler -> \case -- _ -> throwM (ReadException ("no field at key " <> s)) -- _ -> failInvariant "read-integer" --- coreReadString :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +-- coreReadString :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -- coreReadString info b = mkBuiltinFn info b \case -- [VLiteral (LString s)] -> -- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of @@ -637,7 +636,7 @@ coreEnforce info b = mkBuiltinFn info b \cont handler -> \case -- _ -> throwM (ReadException ("no field at key " <> s)) -- _ -> failInvariant "read-string" --- coreReadDecimal :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +-- coreReadDecimal :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -- coreReadDecimal info b = mkBuiltinFn info b \case -- [VLiteral (LString s)] -> -- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of @@ -657,7 +656,7 @@ coreEnforce info b = mkBuiltinFn info b \cont handler -> \case -- _ -> throwM (ReadException ("no field at key " <> s)) -- _ -> failInvariant "readObject" --- coreReadKeyset :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +-- coreReadKeyset :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -- coreReadKeyset info b = mkBuiltinFn info b \case -- [VLiteral (LString s)] -> -- case view (ckeData . envMap . at (Field s)) ?cekRuntimeEnv of @@ -685,12 +684,12 @@ coreEnforce info b = mkBuiltinFn info b \cont handler -> \case -- pure (KeySet ks kspred) --- coreKeysetRefGuard :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +-- coreKeysetRefGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -- coreKeysetRefGuard info b = mkBuiltinFn info b \case -- [VLiteral (LString s)] -> pure (VGuard (GKeySetRef (KeySetName s))) -- _ -> failInvariant "keyset-ref-guard" --- coreEnforceGuard :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +-- coreEnforceGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -- coreEnforceGuard info b = mkBuiltinFn info b \case -- [VGuard v] -> case v of -- GKeyset ks -> enforceKeySet ks @@ -716,7 +715,7 @@ coreEnforce info b = mkBuiltinFn info b \cont handler -> \case -- Just ks -> enforceKeySet ks -- Nothing -> throwM (EnforceException "no such keyset") --- createUserGuard :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +-- createUserGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -- createUserGuard info b = mkBuiltinFn info b \case -- [v@VClosure{}] -> pure (VGuard (GUserGuard v)) -- _ -> failInvariant "create-user-guard" @@ -725,44 +724,48 @@ coreEnforce info b = mkBuiltinFn info b \cont handler -> \case -- Other Core forms ----------------------------------- --- coreIf :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m +-- coreIf :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -- coreIf info b = mkBuiltinFn info b \case -- [VLiteral (LBool b), VClosure tbody tenv, VClosure fbody fenv] -> -- if b then eval tenv tbody else eval fenv fbody -- _ -> failInvariant "if" -coreB64Encode :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreB64Encode info b = mkBuiltinFn info b \cont handler -> \case +coreB64Encode :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreB64Encode = \info b cont handler _env -> \case [VLiteral (LString l)] -> returnCEKValue cont handler $ VLiteral $ LString $ toB64UrlUnpaddedText $ T.encodeUtf8 l args -> argsError info b args -coreB64Decode :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreB64Decode info b = mkBuiltinFn info b \cont handler -> \case +coreB64Decode :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreB64Decode = \info b cont handler _env -> \case [VLiteral (LString s)] -> case fromB64UrlUnpaddedText $ T.encodeUtf8 s of Left{} -> throwExecutionError info (DecodeError "invalid b64 encoding") Right txt -> returnCEKValue cont handler (VLiteral (LString txt)) args -> argsError info b args -coreEnforceGuard :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreEnforceGuard info b = mkBuiltinFn info b \cont handler -> \case +coreEnforceGuard :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreEnforceGuard = \info b cont handler env -> \case [VGuard g] -> case g of GKeyset ks -> do - cond <- enforceKeyset ks + cond <- enforceKeyset ks env if cond then returnCEKValue cont handler VUnit else returnCEK cont handler (VError "enforce keyset failure") GKeySetRef ksn -> do - cond <- enforceKeysetName info ksn + cond <- enforceKeysetName info ksn env if cond then returnCEKValue cont handler VUnit else returnCEK cont handler (VError "enforce keyset failure") - GUserGuard ug -> runUserGuard info cont handler ug + GUserGuard ug -> runUserGuard info cont handler env ug args -> argsError info b args -enforceKeyset :: MonadEval b i m => KeySet FullyQualifiedName -> m Bool -enforceKeyset (KeySet kskeys ksPred) = do - sigs <- M.filterWithKey matchKey . view eeMsgSigs <$> readEnv +enforceKeyset + :: MonadEval b i m + => KeySet FullyQualifiedName + -> CEKEnv b i m + -> m Bool +enforceKeyset (KeySet kskeys ksPred) env = do + let sigs = views (ceEnv.eeMsgSigs) (M.filterWithKey matchKey) env runPred (M.size sigs) where matchKey k _ = k `elem` kskeys @@ -784,11 +787,12 @@ enforceKeysetName :: MonadEval b i m => i -> KeySetName + -> CEKEnv b i m -> m Bool -enforceKeysetName info ksn = do - pactDb <- view eePactDb <$> readEnv +enforceKeysetName info ksn env = do + let pactDb = view (ceEnv.eePactDb) env liftIO (readKeyset pactDb ksn) >>= \case - Just ks -> enforceKeyset ks + Just ks -> enforceKeyset ks env Nothing -> throwExecutionError info (NoSuchKeySet ksn) @@ -797,22 +801,24 @@ runUserGuard => i -> Cont b i m -> CEKErrorHandler b i m + -> CEKEnv b i m -> UserGuard FullyQualifiedName PactValue -> m (EvalResult b i m) -runUserGuard info cont handler (UserGuard fqn args) = +runUserGuard info cont handler env (UserGuard fqn args) = lookupFqName fqn >>= \case Just (Dfun d) -> do when (length (_dfunArgs d) /= length args) $ error "user guard not saturated" -- Todo: this is probably needs to be factored out let li = TLDefun (_fqModule fqn) (_fqName fqn) cloargs = NE.fromList (_argType <$> _dfunArgs d) - clo = Closure li cloargs (NE.length cloargs) (_dfunTerm d) (_dfunRType d) (_dfunInfo d) + clo = Closure li cloargs (NE.length cloargs) (_dfunTerm d) (_dfunRType d) env (_dfunInfo d) + -- Todo: sys only here applyLam (C clo) (VPactValue <$> args) cont handler Just d -> throwExecutionError info (InvalidDefKind (defKind d) "run-user-guard") Nothing -> throwExecutionError info (NameNotInScope fqn) -coreBind :: (IsBuiltin b, MonadEval b i m) => i -> b -> NativeFn b i m -coreBind info b = mkBuiltinFn info b \cont handler -> \case +coreBind :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +coreBind = \info b cont handler _env -> \case [v@VObject{}, VClosure clo] -> applyLam clo [v] cont handler args -> argsError info b args @@ -821,83 +827,79 @@ coreBind info b = mkBuiltinFn info b \cont handler -> \case -- Core definitions ----------------------------------- -unimplemented :: NativeFn b i m +unimplemented :: NativeFunction b i m unimplemented = error "unimplemented" -rawBuiltinRuntime +rawBuiltinEnv :: (MonadEval RawBuiltin i m) - => i - -> RawBuiltin - -> NativeFn RawBuiltin i m -rawBuiltinRuntime = rawBuiltinLiftedRuntime id + => BuiltinEnv RawBuiltin i m +rawBuiltinEnv i b env = mkBuiltinFn i b env (rawBuiltinRuntime b) -rawBuiltinLiftedRuntime +rawBuiltinRuntime :: (MonadEval b i m, IsBuiltin b) - => (RawBuiltin -> b) - -> i - -> RawBuiltin - -> NativeFn b i m -rawBuiltinLiftedRuntime f i = \case - RawAdd -> rawAdd i (f RawAdd) - RawSub -> rawSub i (f RawSub) - RawMultiply -> rawMul i (f RawMultiply) - RawDivide -> rawDiv i (f RawDivide) - RawNegate -> rawNegate i (f RawNegate) - RawAbs -> rawAbs i (f RawAbs) - RawPow -> rawPow i (f RawPow) - RawNot -> notBool i (f RawNot) - RawEq -> rawEq i (f RawEq) - RawNeq -> rawNeq i (f RawNeq) - RawGT -> rawGt i (f RawGT) - RawGEQ -> rawGeq i (f RawGEQ) - RawLT -> rawLt i (f RawLT) - RawLEQ -> rawLeq i (f RawLEQ) - RawBitwiseAnd -> bitAndInt i (f RawBitwiseAnd) - RawBitwiseOr -> bitOrInt i (f RawBitwiseOr) - RawBitwiseXor -> bitXorInt i (f RawBitwiseXor) - RawBitwiseFlip -> bitComplementInt i (f RawBitwiseFlip) - RawBitShift -> bitShiftInt i (f RawBitShift) - RawRound -> roundDec i (f RawRound) - RawCeiling -> ceilingDec i (f RawCeiling) - RawFloor -> floorDec i (f RawFloor) - RawExp -> rawExp i (f RawExp) - RawLn -> rawLn i (f RawLn) - RawSqrt -> rawSqrt i (f RawSqrt) - RawLogBase -> rawLogBase i (f RawLogBase) - RawLength -> rawLength i (f RawLength) - RawTake -> rawTake i (f RawTake) - RawDrop -> rawDrop i (f RawDrop) - RawConcat -> coreConcat i (f RawConcat) - RawReverse -> rawReverse i (f RawReverse) - RawMod -> modInt i (f RawMod) - RawMap -> coreMap i (f RawMap) - RawFilter -> coreFilter i (f RawFilter) - RawZip -> zipList i (f RawZip) + => RawBuiltin + -> NativeFunction b i m +rawBuiltinRuntime = \case + RawAdd -> rawAdd + RawSub -> rawSub + RawMultiply -> rawMul + RawDivide -> rawDiv + RawNegate -> rawNegate + RawAbs -> rawAbs + RawPow -> rawPow + RawNot -> notBool + RawEq -> rawEq + RawNeq -> rawNeq + RawGT -> rawGt + RawGEQ -> rawGeq + RawLT -> rawLt + RawLEQ -> rawLeq + RawBitwiseAnd -> bitAndInt + RawBitwiseOr -> bitOrInt + RawBitwiseXor -> bitXorInt + RawBitwiseFlip -> bitComplementInt + RawBitShift -> bitShiftInt + RawRound -> roundDec + RawCeiling -> ceilingDec + RawFloor -> floorDec + RawExp -> rawExp + RawLn -> rawLn + RawSqrt -> rawSqrt + RawLogBase -> rawLogBase + RawLength -> rawLength + RawTake -> rawTake + RawDrop -> rawDrop + RawConcat -> coreConcat + RawReverse -> rawReverse + RawMod -> modInt + RawMap -> coreMap + RawFilter -> coreFilter + RawZip -> zipList RawIntToStr -> unimplemented RawStrToInt -> unimplemented - RawFold -> coreFold i (f RawFold) + RawFold -> coreFold RawDistinct -> unimplemented - RawContains -> rawContains i (f RawContains) - RawSort -> rawSort i (f RawSort) - RawSortObject -> rawSortObject i (f RawSortObject) - RawRemove -> rawRemove i (f RawRemove) - RawEnforce -> coreEnforce i (f RawEnforce) + RawContains -> rawContains + RawSort -> rawSort + RawSortObject -> rawSortObject + RawRemove -> rawRemove + RawEnforce -> coreEnforce RawEnforceOne -> unimplemented - RawEnumerate -> coreEnumerate i (f RawEnumerate) - RawEnumerateStepN -> coreEnumerateStepN i (f RawEnumerateStepN) - RawShow -> rawShow i (f RawShow) + RawEnumerate -> coreEnumerate + RawEnumerateStepN -> coreEnumerateStepN + RawShow -> rawShow RawReadInteger -> unimplemented RawReadDecimal -> unimplemented RawReadString -> unimplemented RawReadKeyset -> unimplemented - RawEnforceGuard -> coreEnforceGuard i (f RawEnforceGuard) + RawEnforceGuard -> coreEnforceGuard RawKeysetRefGuard -> unimplemented - RawAt -> coreAccess i (f RawAt) - RawMakeList -> makeList i (f RawMakeList) - RawB64Encode -> coreB64Encode i (f RawB64Encode) - RawB64Decode -> coreB64Decode i (f RawB64Decode) - RawStrToList -> strToList i (f RawStrToList) - RawBind -> coreBind i (f RawBind) + RawAt -> coreAccess + RawMakeList -> makeList + RawB64Encode -> coreB64Encode + RawB64Decode -> coreB64Decode + RawStrToList -> strToList + RawBind -> coreBind RawCreateTable -> unimplemented RawDescribeKeyset -> unimplemented RawDescribeModule -> unimplemented diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs index fb9c80669..6d7e24052 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs @@ -13,20 +13,20 @@ module Pact.Core.IR.Eval.Runtime.Types ( CEKTLEnv - , CEKEnv + , CEKEnv(..) + , ceLocal + , ceEnv + , ceBuiltins , EvalEnv(..) + , NativeFunction + , BuiltinEnv , NativeFn(..) , EvalT(..) , runEvalT , CEKValue(..) , Cont(..) - , eeBuiltins - , eeLoaded - , eeGasModel - , eeMHashes, eeMsgSigs - , eePactDb , CEKErrorHandler(..) - , MonadEvalEnv(..) +-- , MonadEvalEnv(..) , MonadEvalState(..) , MonadGas(..) , CondFrame(..) @@ -37,7 +37,7 @@ module Pact.Core.IR.Eval.Runtime.Types , emGas, emGasLog, emRuntimeEnv , EvalState(..) , esCaps, esEvents, esInCap - , esStack + , esStack, esLoaded , pattern VLiteral , pattern VGuard , pattern VList @@ -101,6 +101,7 @@ import Pact.Core.Type import Pact.Core.Persistence import Pact.Core.ModRefs import Pact.Core.Capabilities +import Pact.Core.Environment import qualified Pact.Core.Pretty as P @@ -108,23 +109,33 @@ import qualified Pact.Core.Pretty as P type CEKTLEnv b i = Map FullyQualifiedName (EvalDef b i) -- | Locally bound variables -type CEKEnv b i m = RAList (CEKValue b i m) +-- type CEKEnv b i m = RAList (CEKValue b i m) + +data CEKEnv b i m + = CEKEnv + { _ceLocal :: RAList (CEKValue b i m) + , _ceEnv :: EvalEnv b i + , _ceBuiltins :: BuiltinEnv b i m } + +instance (Show i, Show b) => Show (CEKEnv b i m) where + show (CEKEnv e _ _) = show e -- | List of builtins -type BuiltinEnv b i m = i -> b -> NativeFn b i m +type BuiltinEnv b i m = i -> b -> CEKEnv b i m -> NativeFn b i m newtype StackFrame = StackFrame { _sfLamInfo :: LamInfo } deriving Show -data Closure b i +data Closure b i m = Closure { _cloLamInfo :: !LamInfo , _cloTypes :: !(NonEmpty (Maybe Type)) , _cloArity :: !Int , _cloTerm :: !(EvalTerm b i) , _cloRType :: !(Maybe Type) + , _cloEnv :: !(CEKEnv b i m) , _cloInfo :: i } deriving Show @@ -156,7 +167,7 @@ data PartialClosure b i m } deriving Show data CanApply b i m - = C {-# UNPACK #-} !(Closure b i) + = C {-# UNPACK #-} !(Closure b i m) | LC {-# UNPACK #-} !(LamClosure b i m) | PC {-# UNPACK #-} !(PartialClosure b i m) | N {-# UNPACK #-} !(NativeFn b i m) @@ -215,7 +226,7 @@ pattern VNative clo = VClosure (N clo) pattern VPartialNative :: PartialNativeFn b i m -> CEKValue b i m pattern VPartialNative clo = VClosure (PN clo) -pattern VDefClosure :: Closure b i -> CEKValue b i m +pattern VDefClosure :: Closure b i m -> CEKValue b i m pattern VDefClosure clo = VClosure (C clo) pattern VLamClosure :: LamClosure b i m -> CEKValue b i m @@ -236,16 +247,17 @@ data EvalState b i , _esStack :: [StackFrame] , _esEvents :: [PactEvent b i] , _esInCap :: Bool + , _esLoaded :: Loaded b i } deriving Show -type MonadEval b i m = (MonadEvalEnv b i m, MonadEvalState b i m, MonadGas m, MonadError (PactError i) m, MonadIO m, Default i) +type MonadEval b i m = (MonadEvalState b i m, MonadGas m, MonadError (PactError i) m, MonadIO m, Default i) class Monad m => MonadGas m where logGas :: Text -> Gas -> m () chargeGas :: Gas -> m () -class (Monad m) => MonadEvalEnv b i m | m -> b, m -> i where - readEnv :: m (EvalEnv b i m) +-- class (Monad m) => MonadEvalEnv b i m | m -> b, m -> i where +-- readEnv :: m (EvalEnv b i m) -- | Our monad mirroring `EvalState` for our evaluation state class Monad m => MonadEvalState b i m | m -> b, m -> i where @@ -256,7 +268,7 @@ class Monad m => MonadEvalState b i m | m -> b, m -> i where data EvalTEnv b i m = EvalTEnv - { _emRuntimeEnv :: EvalEnv b i (EvalT b i m) + { _emRuntimeEnv :: CEKEnv b i (EvalT b i m) , _emGas :: IORef Gas , _emGasLog :: IORef (Maybe [(Text, Gas)]) } @@ -278,10 +290,14 @@ runEvalT -> m (a, EvalState b i) runEvalT env st (EvalT action) = runStateT (runReaderT action env) st +type NativeFunction b i m + = i -> b -> Cont b i m -> CEKErrorHandler b i m -> CEKEnv b i m -> [CEKValue b i m] -> m (EvalResult b i m) + data NativeFn b i m = NativeFn { _native :: b - , _nativeFn :: Cont b i m -> CEKErrorHandler b i m -> [CEKValue b i m] -> m (EvalResult b i m) + , _nativeEnv :: CEKEnv b i m + , _nativeFn :: NativeFunction b i m , _nativeArity :: {-# UNPACK #-} !Int , _nativeLoc :: i } @@ -292,7 +308,8 @@ data NativeFn b i m data PartialNativeFn b i m = PartialNativeFn { _pNative :: b - , _pNativeFn :: Cont b i m -> CEKErrorHandler b i m -> [CEKValue b i m] -> m (EvalResult b i m) + , _pNativeEnv :: CEKEnv b i m + , _pNativeFn :: NativeFunction b i m , _pNativeArity :: {-# UNPACK #-} !Int , _pNativeAppliedArgs :: [CEKValue b i m] , _pNativeLoc :: i @@ -391,14 +408,16 @@ data CEKErrorHandler b i m | CEKHandler (CEKEnv b i m) (EvalTerm b i) (Cont b i m) [CapSlot FullyQualifiedName] (CEKErrorHandler b i m) deriving Show -data EvalEnv b i m - = EvalEnv - { _eeBuiltins :: BuiltinEnv b i m - , _eeGasModel :: GasEnv b - , _eeLoaded :: CEKTLEnv b i - , _eeMHashes :: Map ModuleName ModuleHash - , _eeMsgSigs :: Map PublicKeyText (Set (CapToken FullyQualifiedName)) - , _eePactDb :: PactDb b i +-- data EvalEnv b i m +-- = EvalEnv +-- { _eeBuiltins :: BuiltinEnv b i m +-- , _eeGasModel :: GasEnv b +-- , _eeLoaded :: CEKTLEnv b i +-- , _eeMHashes :: Map ModuleName ModuleHash +-- , _eeMsgSigs :: Map PublicKeyText (Set (CapToken FullyQualifiedName)) +-- , _eePactDb :: PactDb b i + + -- _cekGas :: IORef Gas -- , _cekEvalLog :: IORef (Maybe [(Text, Gas)]) -- , _ckeData :: EnvData PactValue @@ -406,10 +425,10 @@ data EvalEnv b i m -- , _ckeResolveName :: QualifiedName -> Maybe FullyQualifiedName -- , _ckeSigs :: Set PublicKey -- , _ckePactDb :: PactDb b i - } + -- } instance (Show i, Show b) => Show (NativeFn b i m) where - show (NativeFn b _ arity _) = unwords + show (NativeFn b _ _ arity _) = unwords ["(NativeFn" , show b , "#fn" @@ -418,7 +437,7 @@ instance (Show i, Show b) => Show (NativeFn b i m) where ] instance (Show i, Show b) => Show (PartialNativeFn b i m) where - show (PartialNativeFn b _ arity _ _) = unwords + show (PartialNativeFn b _ _ arity _ _) = unwords ["(NativeFn" , show b , "#fn" @@ -436,7 +455,8 @@ instance (Show i, Show b, Pretty b) => Pretty (CEKValue b i m) where VClosure{} -> P.angles "closure#" -makeLenses ''EvalEnv +makeLenses ''CEKEnv +-- makeLenses ''EvalEnv makeLenses ''EvalTEnv makeLenses ''EvalState makeLenses ''CapState @@ -453,8 +473,8 @@ instance (MonadIO m) => MonadGas (EvalT b i m) where r <- EvalT $ view emGas liftIO (modifyIORef' r (<> g)) -instance (MonadIO m) => MonadEvalEnv b i (EvalT b i m) where - readEnv = EvalT $ view emRuntimeEnv +-- instance (MonadIO m) => MonadEvalEnv b i (EvalT b i m) where +-- readEnv = EvalT $ view emRuntimeEnv instance Monad m => MonadEvalState b i (EvalT b i m) where getEvalState = EvalT get diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs index 47ca74c16..0e221019e 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs @@ -52,15 +52,17 @@ import Pact.Core.Errors import Pact.Core.IR.Eval.Runtime.Types import Pact.Core.Literal import Pact.Core.Capabilities +import Pact.Core.Persistence mkBuiltinFn :: (IsBuiltin b) => i -> b - -> (Cont b i m -> CEKErrorHandler b i m -> [CEKValue b i m] -> m (EvalResult b i m)) + -> CEKEnv b i m + -> NativeFunction b i m -> NativeFn b i m -mkBuiltinFn i b fn = - NativeFn b fn (builtinArity b) i +mkBuiltinFn i b env fn = + NativeFn b env fn (builtinArity b) i {-# INLINE mkBuiltinFn #-} cfFQN :: Lens' (CapFrame b i) FullyQualifiedName @@ -138,7 +140,7 @@ usesEvalState l f = views l f <$> getEvalState lookupFqName :: (MonadEval b i m) => FullyQualifiedName -> m (Maybe (EvalDef b i)) lookupFqName fqn = - M.lookup fqn . view eeLoaded <$> readEnv + views (esLoaded.loAllLoaded) (M.lookup fqn) <$> getEvalState typecheckArgument :: (MonadEval b i m) => PactValue -> Type -> m PactValue typecheckArgument pv ty = case (pv, checkPvType ty pv) of diff --git a/pact-core/Pact/Core/Repl/Compile.hs b/pact-core/Pact/Core/Repl/Compile.hs index f884777b8..1dbf4850a 100644 --- a/pact-core/Pact/Core/Repl/Compile.hs +++ b/pact-core/Pact/Core/Repl/Compile.hs @@ -28,7 +28,6 @@ import qualified Data.Text as T -- import Pact.Core.Info import Pact.Core.Persistence import Pact.Core.Builtin -import Pact.Core.Gas import Pact.Core.Names import Pact.Core.Repl.Utils import Pact.Core.IR.Desugar @@ -36,11 +35,14 @@ import Pact.Core.Errors import Pact.Core.IR.Term import Pact.Core.Compile import Pact.Core.Interpreter +import Pact.Core.PactValue +import Pact.Core.Environment import Pact.Core.IR.Eval.Runtime import Pact.Core.Repl.Runtime import Pact.Core.Repl.Runtime.ReplBuiltin +import Pact.Core.Hash import qualified Pact.Core.Syntax.ParseTree as Lisp import qualified Pact.Core.Syntax.Lexer as Lisp @@ -106,16 +108,21 @@ interpretReplProgram sc@(SourceCode source) = do evalGas <- use replGas evalLog <- use replEvalLog -- todo: cache? - mhashes <- uses (replLoaded . loModules) (fmap (view mdModuleHash)) - let rEnv = ReplEvalEnv evalGas evalLog - cekEnv = EvalEnv - { _eeBuiltins = replRawBuiltinRuntime - , _eeLoaded = _loAllLoaded lo - , _eeGasModel = freeGasEnv - , _eeMHashes = mhashes - , _eeMsgSigs = mempty - , _eePactDb = pdb } - rState = ReplEvalState cekEnv (EvalState (CapState [] mempty) [] [] False) sc + -- mhashes <- uses (replLoaded . loModules) (fmap (view mdModuleHash)) + let rEnv = ReplEvalEnv evalGas evalLog replBuiltinEnv + evalEnv = EvalEnv + { _eeMsgSigs = mempty + , _eeMsgBody = EnvData mempty + , _eePactDb = pdb + , _eeHash = Hash mempty} + evalState = EvalState + { _esCaps = CapState [] mempty + , _esStack = [] + , _esEvents = [] + , _esInCap = False + , _esLoaded = lo + } + rState = ReplEvalState evalEnv evalState sc liftIO (runReplCEK rEnv rState te) >>= liftEither >>= \case VError txt -> throwError (PEExecutionError (EvalError txt) i) diff --git a/pact-core/Pact/Core/Repl/Runtime.hs b/pact-core/Pact/Core/Repl/Runtime.hs index a0d9a8770..6d4f8c9ce 100644 --- a/pact-core/Pact/Core/Repl/Runtime.hs +++ b/pact-core/Pact/Core/Repl/Runtime.hs @@ -34,11 +34,12 @@ data ReplEvalEnv b i = ReplEvalEnv { _reGas :: IORef Gas , _reGasLog :: IORef (Maybe [(Text, Gas)]) + , _reBuiltins :: BuiltinEnv b i (ReplEvalM b i) } data ReplEvalState b i = ReplEvalState - { _reEnv :: EvalEnv b i (ReplEvalM b i) + { _reEnv :: EvalEnv b i , _reState :: EvalState b i , _reSource :: SourceCode } @@ -69,9 +70,6 @@ instance MonadGas (ReplEvalM b i) where r <- view reGas liftIO (modifyIORef' r (<> g)) -instance MonadEvalEnv b i (ReplEvalM b i) where - readEnv = use reEnv - instance MonadEvalState b i (ReplEvalM b i) where getEvalState = use reState modifyEvalState f = @@ -95,4 +93,4 @@ runReplCEK -> EvalTerm b i -> IO (Either (PactError i) (EvalResult b i (ReplEvalM b i))) runReplCEK env st term = - runReplEvalM env st (eval mempty term) + runReplEvalM env st (eval (CEKEnv mempty (_reEnv st) (_reBuiltins env)) term) diff --git a/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs b/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs index 1e71adbb1..4304d2ecb 100644 --- a/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs +++ b/pact-core/Pact/Core/Repl/Runtime/ReplBuiltin.hs @@ -37,24 +37,24 @@ prettyShowValue = \case VClosure _ -> "<#closure>" -mkReplBuiltinFn - :: (IsBuiltin b) - => i - -> ReplBuiltin b - -> (ReplCont b i -> ReplHandler b i -> [ReplCEKValue b i] -> ReplBM b i (ReplEvalResult b i)) - -> ReplBuiltinFn b i -mkReplBuiltinFn = mkBuiltinFn -{-# INLINE mkReplBuiltinFn #-} - -corePrint :: (IsBuiltin b, Default i) => i -> ReplBuiltin b -> ReplBuiltinFn b i -corePrint info b = mkReplBuiltinFn info b \cont handler -> \case +-- mkReplBuiltinFn +-- :: (IsBuiltin b) +-- => i +-- -> ReplBuiltin b +-- -> (ReplCont b i -> ReplHandler b i -> [ReplCEKValue b i] -> ReplBM b i (ReplEvalResult b i)) +-- -> ReplBuiltinFn b i +-- mkReplBuiltinFn = mkBuiltinFn +-- {-# INLINE mkReplBuiltinFn #-} + +corePrint :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) +corePrint = \info b cont handler _env -> \case [v] -> do liftIO $ putStrLn $ T.unpack (prettyShowValue v) returnCEKValue cont handler (VLiteral LUnit) args -> argsError info b args -rawExpect :: (IsBuiltin b, Default i) => i -> ReplBuiltin b -> ReplBuiltinFn b i -rawExpect info b = mkReplBuiltinFn info b \cont handler -> \case +rawExpect :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) +rawExpect = \info b cont handler _env -> \case [VLiteral (LString msg), VPactValue v1, VClosure clo] -> unsafeApplyOne clo (VLiteral LUnit) >>= \case EvalValue (VPactValue v2) -> @@ -66,8 +66,8 @@ rawExpect info b = mkReplBuiltinFn info b \cont handler -> \case v -> returnCEK cont handler v args -> argsError info b args -coreExpectThat :: (IsBuiltin b, Default i) => i -> ReplBuiltin b -> ReplBuiltinFn b i -coreExpectThat info b = mkReplBuiltinFn info b \cont handler -> \case +coreExpectThat :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) +coreExpectThat = \info b cont handler _env -> \case [VLiteral (LString msg), VClosure vclo, v] -> do unsafeApplyOne vclo v >>= \case EvalValue (VLiteral (LBool c)) -> @@ -77,8 +77,8 @@ coreExpectThat info b = mkReplBuiltinFn info b \cont handler -> \case VError ve -> return (VError ve) args -> argsError info b args -coreExpectFailure :: (IsBuiltin b, Default i) => i -> ReplBuiltin b -> ReplBuiltinFn b i -coreExpectFailure info b = mkReplBuiltinFn info b \cont handler -> \case +coreExpectFailure :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) +coreExpectFailure = \info b cont handler _env -> \case [VLiteral (LString toMatch), VClosure vclo] -> do tryError (unsafeApplyOne vclo (VLiteral LUnit)) >>= \case Right (VError _e) -> @@ -89,28 +89,33 @@ coreExpectFailure info b = mkReplBuiltinFn info b \cont handler -> \case returnCEKValue cont handler $ VLiteral $ LString $ "FAILURE: " <> toMatch <> ": expected failure, got result" args -> argsError info b args -coreEnvStackFrame :: (IsBuiltin b, Default i) => i -> ReplBuiltin b -> ReplBuiltinFn b i -coreEnvStackFrame info b = mkReplBuiltinFn info b \cont handler -> \case +coreEnvStackFrame :: (IsBuiltin b, Default i) => NativeFunction b i (ReplEvalM b i) +coreEnvStackFrame = \info b cont handler _env -> \case [_] -> do frames <- useEvalState esStack liftIO $ print frames returnCEKValue cont handler VUnit args -> argsError info b args +replBuiltinEnv + :: Default i + => BuiltinEnv (ReplBuiltin RawBuiltin) i (ReplEvalM (ReplBuiltin RawBuiltin) i) +replBuiltinEnv i b env = + mkBuiltinFn i b env (replRawBuiltinRuntime b) + replRawBuiltinRuntime :: (Default i) - => i - -> ReplBuiltin RawBuiltin - -> ReplBuiltinFn RawBuiltin i -replRawBuiltinRuntime i = \case + => ReplBuiltin RawBuiltin + -> NativeFunction (ReplBuiltin RawBuiltin) i (ReplEvalM (ReplBuiltin RawBuiltin) i) +replRawBuiltinRuntime = \case RBuiltinWrap cb -> - rawBuiltinLiftedRuntime RBuiltinWrap i cb + rawBuiltinRuntime cb RBuiltinRepl br -> case br of - RExpect -> rawExpect i $ RBuiltinRepl RExpect - RExpectFailure -> coreExpectFailure i $ RBuiltinRepl RExpectFailure - RExpectThat -> coreExpectThat i $ RBuiltinRepl RExpectThat - RPrint -> corePrint i $ RBuiltinRepl RPrint - REnvStackFrame -> coreEnvStackFrame i $ RBuiltinRepl REnvStackFrame + RExpect -> rawExpect + RExpectFailure -> coreExpectFailure + RExpectThat -> coreExpectThat + RPrint -> corePrint + REnvStackFrame -> coreEnvStackFrame -- defaultReplState :: Default i => ReplEvalState (ReplBuiltin RawBuiltin) i -- defaultReplState = ReplEvalState env (EvalState (CapState [] mempty) [] [] False) From 3c244108e6f0a65d500c133bbc452fb0f218b0a2 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Fri, 29 Sep 2023 13:01:03 -0400 Subject: [PATCH 3/5] wip module admin on createtable --- pact-core/Pact/Core/IR/Eval/CEK.hs | 2 + pact-core/Pact/Core/IR/Eval/RawBuiltin.hs | 15 ++++++- pact-core/Pact/Core/IR/Eval/Runtime/Types.hs | 1 + pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs | 47 ++++++++++++++++++++ pact-core/Pact/Core/Persistence.hs | 2 +- pact-core/Pact/Core/Repl/Compile.hs | 2 +- 6 files changed, 65 insertions(+), 4 deletions(-) diff --git a/pact-core/Pact/Core/IR/Eval/CEK.hs b/pact-core/Pact/Core/IR/Eval/CEK.hs index 74e467b94..7183dc7c3 100644 --- a/pact-core/Pact/Core/IR/Eval/CEK.hs +++ b/pact-core/Pact/Core/IR/Eval/CEK.hs @@ -316,6 +316,8 @@ composeCap cont handler env ct@(CapToken fqn args) = do filterIndex :: Int -> [a] -> [a] filterIndex i xs = [x | (x, i') <- zip xs [0..], i /= i'] +-- Todo: +-- `capAutonomous` are what we should use to match semantics accurately. installCap :: (MonadEval b i m) => Cont b i m -> CEKErrorHandler b i m diff --git a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs index de06ec7bf..4b21665ed 100644 --- a/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs +++ b/pact-core/Pact/Core/IR/Eval/RawBuiltin.hs @@ -144,7 +144,7 @@ rawDiv = \info b cont handler _env -> \case args -> argsError info b args rawNegate :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m -rawNegate = \info b cont handler env -> \case +rawNegate = \info b cont handler _env -> \case [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LInteger (negate i))) [VLiteral (LDecimal i)] -> @@ -823,6 +823,17 @@ coreBind = \info b cont handler _env -> \case applyLam clo [v] cont handler args -> argsError info b args + +createTable :: (IsBuiltin b, MonadEval b i m) => NativeFunction b i m +createTable = \info b cont handler env -> \case + [VTable tn mn _ _] -> do + let pdb = view (ceEnv . eePactDb) env + -- Todo: error handling here + -- Todo: guard table + liftIO (_pdbCreateUserTable pdb tn mn) + returnCEKValue cont handler VUnit + args -> argsError info b args + ----------------------------------- -- Core definitions ----------------------------------- @@ -900,7 +911,7 @@ rawBuiltinRuntime = \case RawB64Decode -> coreB64Decode RawStrToList -> strToList RawBind -> coreBind - RawCreateTable -> unimplemented + RawCreateTable -> createTable RawDescribeKeyset -> unimplemented RawDescribeModule -> unimplemented RawDescribeTable -> unimplemented diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs index 6d7e24052..4d12485d6 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Types.hs @@ -362,6 +362,7 @@ data CapState = CapState { _csSlots :: [CapSlot FullyQualifiedName] , _csManaged :: Set ManagedCap + , _csModuleAdmin :: Set ModuleName } deriving Show diff --git a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs index 0e221019e..3d2669fcd 100644 --- a/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs +++ b/pact-core/Pact/Core/IR/Eval/Runtime/Utils.hs @@ -30,14 +30,17 @@ module Pact.Core.IR.Eval.Runtime.Utils , throwExecutionError , throwExecutionError' , argsError + , findCallingModule ) where import Control.Lens hiding ((%%=)) import Control.Monad.Except(MonadError(..)) +import Control.Monad.IO.Class(liftIO) import Data.Map.Strict(Map) import Data.Text(Text) import Data.Set(Set) import Data.Default(def) +import Data.Maybe(mapMaybe, listToMaybe) import qualified Data.Map.Strict as M import qualified Data.Set as Set @@ -53,6 +56,7 @@ import Pact.Core.IR.Eval.Runtime.Types import Pact.Core.Literal import Pact.Core.Capabilities import Pact.Core.Persistence +import Pact.Core.Environment mkBuiltinFn :: (IsBuiltin b) @@ -153,6 +157,49 @@ typecheckArgument pv ty = case (pv, checkPvType ty pv) of maybeTCType :: (MonadEval b i m) => PactValue -> Maybe Type -> m PactValue maybeTCType pv = maybe (pure pv) (typecheckArgument pv) +findCallingModule :: (MonadEval b i m) => m (Maybe ModuleName) +findCallingModule = do + stack <- useEvalState esStack + pure $ listToMaybe $ mapMaybe getLamInfo stack + where + getLamInfo sf = case _sfLamInfo sf of + AnonLamInfo -> Nothing + TLDefun mn _ -> Just mn + TLDefCap mn _ -> Just mn + +-- Todo: MaybeT cleans this up +getCallingModule :: (MonadEval b i m) => m (EvalModule b i) +getCallingModule = findCallingModule >>= \case + Just mn -> useEvalState (esLoaded . loModules . at mn) >>= \case + Just (ModuleData m _) -> pure m + Just (InterfaceData _m _) -> error "called from interface: impossible" + Nothing -> error "no such calling module" + Nothing -> error "no calling module in stack" + + +-- enforceBlessedHashes md mh +-- | _mHash md == mh = return () +-- | mh `Set.member` (_mBlessed md) = return () +-- | otherwise = error "Execution aborted: hash not blessed" + +-- guardForModuleCall env currMod onFound = +-- findCallingModule >>= \case +-- Just mn | mn == currMod -> onFound +-- Nothing -> getModule currMod env >>= acquireModuleAdmin + +-- acquireModuleAdmin md + +getModule :: (MonadEval b i m) => ModuleName -> CEKEnv b i m -> m (EvalModule b i) +getModule mn env = + useEvalState (esLoaded . loModules . at mn) >>= \case + Just (ModuleData md _) -> pure md + Just (InterfaceData _ _) -> error "not a module" + Nothing -> do + let pdb = view (ceEnv . eePactDb) env + liftIO (_pdbRead pdb DModules mn) >>= \case + Just (ModuleData md _) -> pure md + _ -> error "could not find module" + safeTail :: [a] -> [a] safeTail (_:xs) = xs safeTail [] = [] diff --git a/pact-core/Pact/Core/Persistence.hs b/pact-core/Pact/Core/Persistence.hs index 7672b30ec..57cc08695 100644 --- a/pact-core/Pact/Core/Persistence.hs +++ b/pact-core/Pact/Core/Persistence.hs @@ -124,7 +124,7 @@ data PactDb b i , _pdbRead :: forall k v. Domain k v b i -> k -> IO (Maybe v) , _pdbWrite :: forall k v. Domain k v b i -> k -> v -> IO () , _pdbKeys :: forall k v. Domain k v b i -> IO [k] - , _pdbCreateUserTable :: forall k v. Domain k v b i -> TableName -> ModuleName -> IO () + , _pdbCreateUserTable :: TableName -> ModuleName -> IO () } makeClassy ''PactDb diff --git a/pact-core/Pact/Core/Repl/Compile.hs b/pact-core/Pact/Core/Repl/Compile.hs index 1dbf4850a..87278ff2d 100644 --- a/pact-core/Pact/Core/Repl/Compile.hs +++ b/pact-core/Pact/Core/Repl/Compile.hs @@ -116,7 +116,7 @@ interpretReplProgram sc@(SourceCode source) = do , _eePactDb = pdb , _eeHash = Hash mempty} evalState = EvalState - { _esCaps = CapState [] mempty + { _esCaps = CapState [] mempty mempty , _esStack = [] , _esEvents = [] , _esInCap = False From 0f7f970b76faf4341e6ef7ed6b479d4aa4d478b9 Mon Sep 17 00:00:00 2001 From: rsoeldner Date: Fri, 25 Aug 2023 08:38:01 +0200 Subject: [PATCH 4/5] update flakes --- flake.lock | 530 ++++++----------------------------------------------- flake.nix | 19 +- 2 files changed, 74 insertions(+), 475 deletions(-) diff --git a/flake.lock b/flake.lock index d9d6efd1c..cfa63b023 100644 --- a/flake.lock +++ b/flake.lock @@ -16,21 +16,6 @@ "type": "github" } }, - "blank": { - "locked": { - "lastModified": 1625557891, - "narHash": "sha256-O8/MWsPBGhhyPoPLHZAuoZiiHo9q6FLlEeIDEXuj6T4=", - "owner": "divnix", - "repo": "blank", - "rev": "5a5d2684073d9f563072ed07c871d577a6c614a8", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "blank", - "type": "github" - } - }, "cabal-32": { "flake": false, "locked": { @@ -98,64 +83,6 @@ "type": "github" } }, - "devshell": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1663445644, - "narHash": "sha256-+xVlcK60x7VY1vRJbNUEAHi17ZuoQxAIH4S4iUFUGBA=", - "owner": "numtide", - "repo": "devshell", - "rev": "e3dc3e21594fe07bdb24bdf1c8657acaa4cb8f66", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "devshell", - "type": "github" - } - }, - "dmerge": { - "inputs": { - "nixlib": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ], - "yants": [ - "haskellNix", - "tullia", - "std", - "yants" - ] - }, - "locked": { - "lastModified": 1659548052, - "narHash": "sha256-fzI2gp1skGA8mQo/FBFrUAtY0GQkAIAaV/V127TJPyY=", - "owner": "divnix", - "repo": "data-merge", - "rev": "d160d18ce7b1a45b88344aa3f13ed1163954b497", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "data-merge", - "type": "github" - } - }, "flake-compat": { "flake": false, "locked": { @@ -173,32 +100,16 @@ "type": "github" } }, - "flake-compat_2": { - "flake": false, - "locked": { - "lastModified": 1650374568, - "narHash": "sha256-Z+s0J8/r907g149rllvwhb4pKi8Wam5ij0st8PwAh+E=", - "owner": "edolstra", - "repo": "flake-compat", - "rev": "b4a34015c698c7793d592d66adbab377907a2be8", - "type": "github" - }, - "original": { - "owner": "edolstra", - "repo": "flake-compat", - "type": "github" - } - }, "flake-utils": { "inputs": { "systems": "systems" }, "locked": { - "lastModified": 1681202837, - "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=", + "lastModified": 1689068808, + "narHash": "sha256-6ixXo3wt24N/melDWjq70UuHQLxGV8jZvooRanIHXw0=", "owner": "numtide", "repo": "flake-utils", - "rev": "cfacdce06f30d2b68473a46042957675eebb3401", + "rev": "919d646de7be200f3bf08cb76ae1f09402b6f9b4", "type": "github" }, "original": { @@ -223,36 +134,6 @@ "type": "github" } }, - "flake-utils_3": { - "locked": { - "lastModified": 1653893745, - "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_4": { - "locked": { - "lastModified": 1659877975, - "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, "ghc-8.6.5-iohk": { "flake": false, "locked": { @@ -270,33 +151,14 @@ "type": "github" } }, - "gomod2nix": { - "inputs": { - "nixpkgs": "nixpkgs_2", - "utils": "utils" - }, - "locked": { - "lastModified": 1655245309, - "narHash": "sha256-d/YPoQ/vFn1+GTmSdvbSBSTOai61FONxB4+Lt6w/IVI=", - "owner": "tweag", - "repo": "gomod2nix", - "rev": "40d32f82fc60d66402eb0972e6e368aeab3faf58", - "type": "github" - }, - "original": { - "owner": "tweag", - "repo": "gomod2nix", - "type": "github" - } - }, "hackage": { "flake": false, "locked": { - "lastModified": 1682555144, - "narHash": "sha256-A64bJ9MZhNplD74OQOOF+JZq4BaV2gAuYuIZC/6WA94=", + "lastModified": 1692318155, + "narHash": "sha256-e4npK3xeIIIzq1MDFYhpT3cR37DtEttOdGE7uFi71PQ=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "1cf7e1a3746cc285aeebb0f87fbed10e23aa6b70", + "rev": "0a259b13134e5ac7f9ca408365fd240bd4b42645", "type": "github" }, "original": { @@ -317,6 +179,7 @@ "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", "hackage": "hackage", "hls-1.10": "hls-1.10", + "hls-2.0": "hls-2.0", "hpc-coveralls": "hpc-coveralls", "hydra": "hydra", "iserv-proxy": "iserv-proxy", @@ -329,17 +192,17 @@ "nixpkgs-2111": "nixpkgs-2111", "nixpkgs-2205": "nixpkgs-2205", "nixpkgs-2211": "nixpkgs-2211", + "nixpkgs-2305": "nixpkgs-2305", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", - "stackage": "stackage", - "tullia": "tullia" + "stackage": "stackage" }, "locked": { - "lastModified": 1682583633, - "narHash": "sha256-ws/1ZuZHboqMGzd2Zdfa7o5Sq1V2AgTUSZQkVY1N8pQ=", + "lastModified": 1692319830, + "narHash": "sha256-KD5SPPtJETa83lWr5WwhWWRbSelGhGSkeZ7cqweJfoc=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "6ab363fc7df582147a0629ba6df064ea96c500b0", + "rev": "90e45988f1ad35d55e890cef16d7b1a5de5e6196", "type": "github" }, "original": { @@ -365,6 +228,23 @@ "type": "github" } }, + "hls-2.0": { + "flake": false, + "locked": { + "lastModified": 1687698105, + "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "783905f211ac63edf982dd1889c671653327e441", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.0.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, "hpc-coveralls": { "flake": false, "locked": { @@ -404,37 +284,14 @@ "type": "indirect" } }, - "incl": { - "inputs": { - "nixlib": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1669263024, - "narHash": "sha256-E/+23NKtxAqYG/0ydYgxlgarKnxmDbg6rCMWnOBqn9Q=", - "owner": "divnix", - "repo": "incl", - "rev": "ce7bebaee048e4cd7ebdb4cee7885e00c4e2abca", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "incl", - "type": "github" - } - }, "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1670983692, - "narHash": "sha256-avLo34JnI9HNyOuauK5R69usJm+GfW3MlyGlYxZhTgY=", + "lastModified": 1688517130, + "narHash": "sha256-hUqfxSlo+ffqVdkSZ1EDoB7/ILCL25eYkcCXW9/P3Wc=", "ref": "hkm/remote-iserv", - "rev": "50d0abb3317ac439a4e7495b185a64af9b7b9300", - "revCount": 10, + "rev": "9151db2a9a61d7f5fe52ff8836f18bbd0fd8933c", + "revCount": 13, "type": "git", "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" }, @@ -460,35 +317,6 @@ "type": "github" } }, - "n2c": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1665039323, - "narHash": "sha256-SAh3ZjFGsaCI8FRzXQyp56qcGdAqgKEfJWPCQ0Sr7tQ=", - "owner": "nlewo", - "repo": "nix2container", - "rev": "b008fe329ffb59b67bf9e7b08ede6ee792f2741a", - "type": "github" - }, - "original": { - "owner": "nlewo", - "repo": "nix2container", - "type": "github" - } - }, "nix": { "inputs": { "lowdown-src": "lowdown-src", @@ -510,95 +338,6 @@ "type": "github" } }, - "nix-nomad": { - "inputs": { - "flake-compat": "flake-compat_2", - "flake-utils": [ - "haskellNix", - "tullia", - "nix2container", - "flake-utils" - ], - "gomod2nix": "gomod2nix", - "nixpkgs": [ - "haskellNix", - "tullia", - "nixpkgs" - ], - "nixpkgs-lib": [ - "haskellNix", - "tullia", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1658277770, - "narHash": "sha256-T/PgG3wUn8Z2rnzfxf2VqlR1CBjInPE0l1yVzXxPnt0=", - "owner": "tristanpemble", - "repo": "nix-nomad", - "rev": "054adcbdd0a836ae1c20951b67ed549131fd2d70", - "type": "github" - }, - "original": { - "owner": "tristanpemble", - "repo": "nix-nomad", - "type": "github" - } - }, - "nix2container": { - "inputs": { - "flake-utils": "flake-utils_3", - "nixpkgs": "nixpkgs_3" - }, - "locked": { - "lastModified": 1658567952, - "narHash": "sha256-XZ4ETYAMU7XcpEeAFP3NOl9yDXNuZAen/aIJ84G+VgA=", - "owner": "nlewo", - "repo": "nix2container", - "rev": "60bb43d405991c1378baf15a40b5811a53e32ffa", - "type": "github" - }, - "original": { - "owner": "nlewo", - "repo": "nix2container", - "type": "github" - } - }, - "nixago": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixago-exts": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1661824785, - "narHash": "sha256-/PnwdWoO/JugJZHtDUioQp3uRiWeXHUdgvoyNbXesz8=", - "owner": "nix-community", - "repo": "nixago", - "rev": "8c1f9e5f1578d4b2ea989f618588d62a335083c3", - "type": "github" - }, - "original": { - "owner": "nix-community", - "repo": "nixago", - "type": "github" - } - }, "nixpkgs": { "locked": { "lastModified": 1657693803, @@ -665,11 +404,11 @@ }, "nixpkgs-2205": { "locked": { - "lastModified": 1672580127, - "narHash": "sha256-3lW3xZslREhJogoOkjeZtlBtvFMyxHku7I/9IVehhT8=", + "lastModified": 1685573264, + "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "0874168639713f547c05947c76124f78441ea46c", + "rev": "380be19fbd2d9079f677978361792cb25e8a3635", "type": "github" }, "original": { @@ -681,11 +420,11 @@ }, "nixpkgs-2211": { "locked": { - "lastModified": 1675730325, - "narHash": "sha256-uNvD7fzO5hNlltNQUAFBPlcEjNG5Gkbhl/ROiX+GZU4=", + "lastModified": 1688392541, + "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "b7ce17b1ebf600a72178f6302c77b6382d09323f", + "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", "type": "github" }, "original": { @@ -695,86 +434,55 @@ "type": "github" } }, - "nixpkgs-regression": { - "locked": { - "lastModified": 1643052045, - "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", - "type": "github" - }, - "original": { - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", - "type": "github" - } - }, - "nixpkgs-unstable": { + "nixpkgs-2305": { "locked": { - "lastModified": 1675758091, - "narHash": "sha256-7gFSQbSVAFUHtGCNHPF7mPc5CcqDk9M2+inlVPZSneg=", + "lastModified": 1690680713, + "narHash": "sha256-NXCWA8N+GfSQyoN7ZNiOgq/nDJKOp5/BHEpiZP8sUZw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "747927516efcb5e31ba03b7ff32f61f6d47e7d87", + "rev": "b81af66deb21f73a70c67e5ea189568af53b1e8c", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-unstable", + "ref": "nixpkgs-23.05-darwin", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs_2": { + "nixpkgs-regression": { "locked": { - "lastModified": 1653581809, - "narHash": "sha256-Uvka0V5MTGbeOfWte25+tfRL3moECDh1VwokWSZUdoY=", + "lastModified": 1643052045, + "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "83658b28fe638a170a19b8933aa008b30640fbd1", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixos-unstable", "repo": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" } }, - "nixpkgs_3": { + "nixpkgs-unstable": { "locked": { - "lastModified": 1654807842, - "narHash": "sha256-ADymZpr6LuTEBXcy6RtFHcUZdjKTBRTMYwu19WOx17E=", + "lastModified": 1690720142, + "narHash": "sha256-GywuiZjBKfFkntQwpNQfL+Ksa2iGjPprBGL0/psgRZM=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "fc909087cc3386955f21b4665731dbdaceefb1d8", + "rev": "3acb5c4264c490e7714d503c7166a3fde0c51324", "type": "github" }, "original": { "owner": "NixOS", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_4": { - "locked": { - "lastModified": 1665087388, - "narHash": "sha256-FZFPuW9NWHJteATOf79rZfwfRn5fE0wi9kRzvGfDHPA=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "95fda953f6db2e9496d2682c4fc7b82f959878f7", - "type": "github" - }, - "original": { - "owner": "nixos", "ref": "nixpkgs-unstable", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs_5": { + "nixpkgs_2": { "locked": { "lastModified": 1669833724, "narHash": "sha256-/HEZNyGbnQecrgJnfE8d0WC5c1xuPSD2LUpB6YXlg4c=", @@ -790,21 +498,6 @@ "type": "github" } }, - "nosys": { - "locked": { - "lastModified": 1667881534, - "narHash": "sha256-FhwJ15uPLRsvaxtt/bNuqE/ykMpNAPF0upozFKhTtXM=", - "owner": "divnix", - "repo": "nosys", - "rev": "2d0d5207f6a230e9d0f660903f8db9807b54814f", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "nosys", - "type": "github" - } - }, "old-ghc-nix": { "flake": false, "locked": { @@ -826,17 +519,17 @@ "inputs": { "flake-utils": "flake-utils", "haskellNix": "haskellNix", - "nixpkgs": "nixpkgs_5" + "nixpkgs": "nixpkgs_2" } }, "stackage": { "flake": false, "locked": { - "lastModified": 1682467738, - "narHash": "sha256-zV/OwQDZt2rignAWhEEL3fa3+pMd9q1+2zRoNtDJi4s=", + "lastModified": 1692317324, + "narHash": "sha256-AofEuurJHrfMljrCAkMKTWBC5xGluhBZiAfHQ73224Y=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "fafaa2484ec29531796569f85d20ff30c363e8fc", + "rev": "4812a420235589a74f9278cca81f6dbf74ffb42f", "type": "github" }, "original": { @@ -845,51 +538,6 @@ "type": "github" } }, - "std": { - "inputs": { - "arion": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "blank": "blank", - "devshell": "devshell", - "dmerge": "dmerge", - "flake-utils": "flake-utils_4", - "incl": "incl", - "makes": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "microvm": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "n2c": "n2c", - "nixago": "nixago", - "nixpkgs": "nixpkgs_4", - "nosys": "nosys", - "yants": "yants" - }, - "locked": { - "lastModified": 1674526466, - "narHash": "sha256-tMTaS0bqLx6VJ+K+ZT6xqsXNpzvSXJTmogkraBGzymg=", - "owner": "divnix", - "repo": "std", - "rev": "516387e3d8d059b50e742a2ff1909ed3c8f82826", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "std", - "type": "github" - } - }, "systems": { "locked": { "lastModified": 1681028828, @@ -904,68 +552,6 @@ "repo": "default", "type": "github" } - }, - "tullia": { - "inputs": { - "nix-nomad": "nix-nomad", - "nix2container": "nix2container", - "nixpkgs": [ - "haskellNix", - "nixpkgs" - ], - "std": "std" - }, - "locked": { - "lastModified": 1675695930, - "narHash": "sha256-B7rEZ/DBUMlK1AcJ9ajnAPPxqXY6zW2SBX+51bZV0Ac=", - "owner": "input-output-hk", - "repo": "tullia", - "rev": "621365f2c725608f381b3ad5b57afef389fd4c31", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "tullia", - "type": "github" - } - }, - "utils": { - "locked": { - "lastModified": 1653893745, - "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "yants": { - "inputs": { - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1667096281, - "narHash": "sha256-wRRec6ze0gJHmGn6m57/zhz/Kdvp9HS4Nl5fkQ+uIuA=", - "owner": "divnix", - "repo": "yants", - "rev": "d18f356ec25cb94dc9c275870c3a7927a10f8c3c", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "yants", - "type": "github" - } } }, "root": "root", diff --git a/flake.nix b/flake.nix index ea80a4e13..f2f30690d 100644 --- a/flake.nix +++ b/flake.nix @@ -24,10 +24,10 @@ pact-core = final.haskell-nix.project' { src = ./.; - compiler-nix-name = "ghc8107"; + compiler-nix-name = "ghc962"; shell.tools = { cabal = {}; - # haskell-language-server = {}; + haskell-language-server = {}; }; shell.buildInputs = with pkgs; [ zlib @@ -37,7 +37,14 @@ }; }) ]; - in flake // { + # This package depends on other packages at buildtime, but its output does not + # depend on them. This way, we don't have to download the entire closure to verify + # that those packages build. + mkCheck = name: package: pkgs.runCommand ("check-"+name) {} '' + echo ${name}: ${package} + echo works > $out + ''; + in flake // rec { packages.default = flake.packages."pact-core:exe:repl"; devShell = pkgs.haskellPackages.shellFor { @@ -46,9 +53,15 @@ buildInputs = with pkgs.haskellPackages; [ cabal-install + haskell-language-server ]; withHoogle = true; }; + packages.check = pkgs.runCommand "check" {} '' + echo ${mkCheck "pact-core" packages.default} + echo ${mkCheck "devShell" flake.devShell} + echo works > $out + ''; }); } From a056be82fcd6054c0323e6e81c03b29fb86573d0 Mon Sep 17 00:00:00 2001 From: rsoeldner Date: Fri, 25 Aug 2023 08:38:22 +0200 Subject: [PATCH 5/5] add nix building + cache action --- .github/workflows/nix.yml | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 .github/workflows/nix.yml diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml new file mode 100644 index 000000000..e1b7e475d --- /dev/null +++ b/.github/workflows/nix.yml @@ -0,0 +1,34 @@ +name: Build and cache with Nix + +on: + workflow_dispatch: + push: + +jobs: + build-and-cache: + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ubuntu-latest, mac-m1] + steps: + - name: Checkout repository + uses: actions/checkout@v3 + + - name: Set up Nix with caching + uses: kadena-io/setup-nix-with-cache@v1 + with: + cache_url: s3://nixcache.chainweb.com?region=us-east-1 + signing_private_key: ${{ secrets.NIX_CACHE_PRIVATE_KEY }} + + - name: Set up AWS credentials + uses: aws-actions/configure-aws-credentials@v2 + with: + aws-access-key-id: ${{ secrets.NIX_CACHE_AWS_ACCESS_KEY_ID }} + aws-secret-access-key: ${{ secrets.NIX_CACHE_AWS_SECRET_ACCESS_KEY }} + aws-region: us-east-1 + + - name: Build and cache artifacts + timeout-minutes: 740 + run: | + echo Building the default package and its devShell + nix build .#check