Merge pull request #28 from kadena-io/jose/module-hashing

Module hashing + Defconst eval

pact-core-tests/pact-tests/modulehash.repl

@@ -0,0 +1,108 @@
+(env-data {'k:1})
+
+(defun check-hash-equivalent (mstring:string h:string)
+  (expect (concat ["Hash of module ", mstring, " matches"]) (at "hash" (describe-module mstring)) h)
+  )
+
+(module m m-gov
+  (defcap m-gov () true)
+
+  (defconst fconst:integer (read-integer "k"))
+
+  (defun mdfn () 1)
+
+  (defpact mdpact ()
+    (step 1))
+
+  (defschema sc a:integer)
+
+  (deftable mdtbl:{sc})
+  )
+
+; base case
+(check-hash-equivalent "m" "QCLU54Co9PbQqiqFz1F3M-pPgdn59ANGIG7bwNVFAJk")
+
+(env-data {'k:2})
+(module m m-gov
+  (defcap m-gov () true)
+
+  (defconst fconst:integer (read-integer "k"))
+
+  (defun mdfn () 1)
+
+  (defpact mdpact ()
+    (step 1))
+
+  (defschema sc a:integer)
+
+  (deftable mdtbl:{sc})
+  )
+
+
+; Defconst changed, ensure hash changed
+(check-hash-equivalent "m" "83c6a-9Hmv9yHOkaY1Y2LmHoHvXLWYc_lQ-Oacg8URw")
+
+(module m m-gov
+  (defcap m-gov () true)
+
+  (defconst fconst:integer (read-integer "k"))
+
+  (defun mdfn () 2)
+
+  (defpact mdpact ()
+    (step 1))
+
+  (defschema sc a:integer)
+
+  (deftable mdtbl:{sc})
+  )
+
+
+; Basic code changed: hash should change
+(check-hash-equivalent "m" "WhYWXrM3oUwXRaiPela_j7d2nF5snW5SPjGUOuuJu7c")
+
+; Modules, interfaces and deps
+(module n gg
+  (use m)
+  (defcap gg () true)
+
+  (defconst nfconst:integer (read-integer "k"))
+
+  (defun nf () (mdfn))
+
+  )
+
+(check-hash-equivalent "n" "v30ra86hQ35kT1k8pdXnGsGU434VD7Ysa7smYhHFPs0")
+
+; Update dependent module, ensure hash changes
+(module m m-gov
+  (defcap m-gov () true)
+
+  (defconst fconst:integer (read-integer "k"))
+
+  (defun mdfn () 3)
+
+  (defpact mdpact ()
+    (step 1))
+
+  (defschema sc a:integer)
+
+  (deftable mdtbl:{sc})
+  )
+
+; n has not changed, but m has, it should change the dep
+(module n gg
+  (use m)
+  (defcap gg () true)
+
+  (defconst nfconst:integer (read-integer "k"))
+
+  (defun nf () (mdfn))
+
+  )
+
+; m changed, hash should have changed
+(check-hash-equivalent "m" "BVrxWuHbjy9heR9AhAZnbusKvSKiyzrEYt8_0LCBRqs")
+
+; n did not change, but the dependency hash changed, so it should also change the hash
+(check-hash-equivalent "n" "ETUjfmMviiXCyZYxJLzk1uXBQFizGizyqPGz1XIt1lA")

pact-core.cabal

@@ -51,6 +51,7 @@ common pact-core-common
     , primitive
     , haskeline
     , semirings
+    , utf8-string
     , exceptions
     , array
     , pact-json
@@ -123,6 +124,8 @@ library
     Pact.Core.IR.Eval.Runtime.Utils
     Pact.Core.IR.Eval.CEK
     Pact.Core.IR.Eval.RawBuiltin
+    Pact.Core.IR.ModuleHashing
+    Pact.Core.IR.ConstEval
 
     -- Repl
     Pact.Core.Repl.Utils

pact-core/Pact/Core/Capabilities.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GADTs #-}
 
 
 module Pact.Core.Capabilities
@@ -19,6 +20,7 @@ module Pact.Core.Capabilities
  , mcCap, mcManaged, mcOriginalCap
  , ManagedCapType(..)
  , PactEvent(..)
+ , dcMetaFqName
  ) where
 
 import Control.Lens
@@ -42,6 +44,12 @@ data DefCapMeta name
   | Unmanaged
   deriving (Show)
 
+dcMetaFqName :: Traversal' (DefCapMeta Name) FullyQualifiedName
+dcMetaFqName f = \case
+  DefManaged (DefManagedMeta i (FQName fqn)) ->
+    DefManaged . DefManagedMeta i . FQName <$> f fqn
+  p -> pure p
+
 data CapForm name e
   = WithCapability name [e] e
   | CreateUserGuard name [e]

pact-core/Pact/Core/Compile.hs

@@ -38,7 +38,10 @@ import Pact.Core.Capabilities
 import Pact.Core.Literal
 import Pact.Core.Imports
 import Pact.Core.Namespace
+import Pact.Core.Hash
 
+import qualified Pact.Core.IR.ModuleHashing as MHash
+import qualified Pact.Core.IR.ConstEval as ConstEval
 import qualified Pact.Core.Syntax.Lexer as Lisp
 import qualified Pact.Core.Syntax.Parser as Lisp
 import qualified Pact.Core.Syntax.ParseTree as Lisp
@@ -47,6 +50,7 @@ type HasCompileEnv b i  m
   = ( MonadEval b i m
     , DesugarBuiltin b
     , Pretty b
+    , IsBuiltin b
     , PhaseDebug b i m)
 
 _parseOnly
@@ -59,8 +63,8 @@ _parseOnlyFile :: FilePath -> IO (Either PactErrorI [Lisp.TopLevel SpanInfo])
 _parseOnlyFile fp = _parseOnly <$> B.readFile fp
 
 data CompileValue b
-  = LoadedModule ModuleName
-  | LoadedInterface ModuleName
+  = LoadedModule ModuleName ModuleHash
+  | LoadedInterface ModuleName ModuleHash
   | LoadedImports Import
   | InterpretValue InterpretValue
   deriving Show
@@ -111,7 +115,7 @@ evalModuleGovernance interp tl = do
               let cgBody = Constant LUnit info
                   term = CapabilityForm (WithCapability (fqnToName fqn) [] cgBody) info
               pure term
-          void (_interpret interp term)
+          void (_interpret interp PReadOnly term)
           esCaps . csModuleAdmin %== S.insert (Lisp._mName m)
           -- | Restore the state to pre-module admin acquisition
           esLoaded .== lo
@@ -127,7 +131,7 @@ evalModuleGovernance interp tl = do
     _ -> pure ()
 
 interpretTopLevel
-  :: forall b i  m
+  :: forall b i m
   .  (HasCompileEnv b i m)
   => Interpreter b i m
   -> Lisp.TopLevel i
@@ -138,30 +142,40 @@ interpretTopLevel interp tl = do
   -- Todo: pretty instance for modules and all of toplevel
   debugPrint (DPParser @b) tl
   (DesugarOutput ds deps) <- runDesugarTopLevel tl
+  constEvaled <- ConstEval.evalTLConsts interp ds
+  let tlFinal = MHash.hashTopLevel constEvaled
   debugPrint DPDesugar ds
   lo0 <- useEvalState esLoaded
-  case ds of
+  case tlFinal of
     TLModule m -> do
       let deps' = M.filterWithKey (\k _ -> S.member (_fqModule k) deps) (_loAllLoaded lo0)
           mdata = ModuleData m deps'
       liftDbFunction (_mInfo m) (writeModule pdb Write (view mName m) mdata)
-      let newLoaded = M.fromList $ toFqDep (_mName m) (_mHash m) <$> _mDefs m
+      let fqDeps = toFqDep (_mName m) (_mHash m) <$> _mDefs m
+          newLoaded = M.fromList fqDeps
+          newTopLevel = M.fromList $ (\(fqn, d) -> (_fqName fqn, (fqn, defKind d))) <$> fqDeps
           loadNewModule =
             over loModules (M.insert (_mName m) mdata) .
-            over loAllLoaded (M.union newLoaded)
+            over loAllLoaded (M.union newLoaded) .
+            over loToplevel (M.union newTopLevel)
       esLoaded %== loadNewModule
       esCaps . csModuleAdmin %== S.union (S.singleton (_mName m))
-      pure (LoadedModule (_mName m))
+      pure (LoadedModule (_mName m) (_mHash m))
     TLInterface iface -> do
       let deps' = M.filterWithKey (\k _ -> S.member (_fqModule k) deps) (_loAllLoaded lo0)
           mdata = InterfaceData iface deps'
       liftDbFunction (_ifInfo iface) (writeModule pdb Write (view ifName iface) mdata)
-      let newLoaded = M.fromList $ toFqDep (_ifName iface) (_ifHash iface)
-                      <$> mapMaybe ifDefToDef (_ifDefns iface)
+      let fqDeps = toFqDep (_ifName iface) (_ifHash iface)
+                   <$> mapMaybe ifDefToDef (_ifDefns iface)
+          newLoaded = M.fromList fqDeps
+          newTopLevel = M.fromList
+                        $ (\(fqn, d) -> (_fqName fqn, (fqn, defKind d)))
+                        <$> fqDeps
           loadNewModule =
             over loModules (M.insert (_ifName iface) mdata) .
-            over loAllLoaded (M.union newLoaded)
+            over loAllLoaded (M.union newLoaded) .
+            over loToplevel (M.union newTopLevel)
       esLoaded %== loadNewModule
-      pure (LoadedInterface (view ifName iface))
-    TLTerm term -> InterpretValue <$> _interpret interp term
+      pure (LoadedInterface (view ifName iface) (view ifHash iface))
+    TLTerm term -> InterpretValue <$> _interpret interp PImpure term
     TLUse imp _ -> pure (LoadedImports imp)

pact-core/Pact/Core/Environment/Utils.hs

@@ -1,15 +1,11 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE InstanceSigs #-}
+
 
 module Pact.Core.Environment.Utils
  ( setEvalState
@@ -29,6 +25,7 @@ module Pact.Core.Environment.Utils
  ) where
 
 import Control.Lens
+import Control.Applicative((<|>))
 import Control.Monad.Except
 import Data.Default
 import Data.Maybe(mapMaybe)
@@ -86,7 +83,7 @@ lookupModule info pdb mn =
    Nothing -> do
     liftDbFunction info (_pdbRead pdb DModules mn) >>= \case
       Just mdata@(ModuleData md deps) -> do
-        let newLoaded = M.fromList $ toFqDep mn (_mHash md) <$> (_mDefs md)
+        let newLoaded = M.fromList $ toFqDep mn (_mHash md) <$> _mDefs md
         (esLoaded . loAllLoaded) %== M.union newLoaded . M.union deps
         (esLoaded . loModules) %== M.insert mn mdata
         pure (Just md)
@@ -102,7 +99,7 @@ lookupModuleData info pdb mn =
    Nothing -> do
     liftDbFunction info (_pdbRead pdb DModules mn) >>= \case
       Just mdata@(ModuleData md deps) -> do
-        let newLoaded = M.fromList $ toFqDep mn (_mHash md) <$> (_mDefs md)
+        let newLoaded = M.fromList $ toFqDep mn (_mHash md) <$> _mDefs md
         (esLoaded . loAllLoaded) %== M.union newLoaded . M.union deps
         (esLoaded . loModules) %== M.insert mn mdata
         pure (Just mdata)
@@ -125,7 +122,7 @@ getModule info pdb mn =
    Nothing -> do
     liftDbFunction info (_pdbRead pdb DModules mn) >>= \case
       Just mdata@(ModuleData md deps) -> do
-        let newLoaded = M.fromList $ toFqDep mn (_mHash md) <$> (_mDefs md)
+        let newLoaded = M.fromList $ toFqDep mn (_mHash md) <$> _mDefs md
         (esLoaded . loAllLoaded) %== M.union newLoaded . M.union deps
         (esLoaded . loModules) %== M.insert mn mdata
         pure md
@@ -142,7 +139,7 @@ getModuleData info pdb mn =
    Nothing -> do
     liftDbFunction info (_pdbRead pdb DModules mn) >>= \case
       Just mdata@(ModuleData md deps) -> do
-        let newLoaded = M.fromList $ toFqDep mn (_mHash md) <$> (_mDefs md)
+        let newLoaded = M.fromList $ toFqDep mn (_mHash md) <$> _mDefs md
         (esLoaded . loAllLoaded) %== M.union newLoaded . M.union deps
         (esLoaded . loModules) %== M.insert mn mdata
         pure mdata
@@ -170,4 +167,4 @@ mangleNamespace :: (MonadEvalState b i m) => ModuleName -> m ModuleName
 mangleNamespace mn@(ModuleName mnraw ns) =
   useEvalState (esLoaded . loNamespace) >>= \case
     Nothing -> pure mn
-    Just (Namespace currNs _ _) -> pure (ModuleName mnraw (maybe (Just currNs) Just ns))
+    Just (Namespace currNs _ _) -> pure (ModuleName mnraw (ns <|> Just currNs))

pact-core/Pact/Core/Errors.hs

@@ -334,6 +334,7 @@ data EvalError
   | NamespaceInstallError Text
   | DefineNamespaceError Text
   -- ^ Non-recoverable guard enforces.
+  | ConstIsNotAPactValue QualifiedName
   deriving Show
 
 

pact-core/Pact/Core/Hash.hs

@@ -25,6 +25,8 @@ module Pact.Core.Hash
 , toB64UrlUnpaddedText
 , fromB64UrlUnpaddedText
 , defaultPactHash
+, placeholderHash
+, moduleHashToText
 ) where
 
 import Control.DeepSeq
@@ -59,6 +61,9 @@ instance Pretty Hash where
 hashToText :: Hash -> Text
 hashToText (Hash h) = toB64UrlUnpaddedText (fromShort h)
 
+moduleHashToText :: ModuleHash -> Text
+moduleHashToText (ModuleHash h) = hashToText h
+
 pactHash :: ByteString -> Hash
 pactHash = hash
 
@@ -116,5 +121,8 @@ newtype ModuleHash = ModuleHash { _mhHash :: Hash }
   deriving (Eq, Ord, Show)
   deriving newtype (NFData)
 
+placeholderHash :: ModuleHash
+placeholderHash = ModuleHash (Hash "#placeholder")
+
 defaultPactHash :: Hash
 defaultPactHash = pactHash ""