Namespaces

src-ghc/Pact/Interpreter.hs

@@ -23,6 +23,7 @@ import Control.Monad.Catch
 import Data.Maybe
 import qualified Data.HashMap.Strict as HM
 
+import Pact.Types.Term
 import Pact.Types.Runtime
 import Pact.Compile
 import Pact.Eval
@@ -68,8 +69,14 @@ evalContinuation :: EvalEnv e -> Term Name -> IO EvalResult
 evalContinuation ee pact = interpret ee [pact]
 
 
-setupEvalEnv :: PactDbEnv e -> Maybe EntityName -> ExecutionMode ->
-                MsgData -> RefStore -> GasEnv -> EvalEnv e
+setupEvalEnv
+  :: PactDbEnv e
+  -> Maybe EntityName
+  -> ExecutionMode
+  -> MsgData
+  -> RefStore
+  -> GasEnv
+  -> EvalEnv e
 setupEvalEnv dbEnv ent mode msgData refStore gasEnv =
   EvalEnv {
     _eeRefStore = refStore

src-ghc/Pact/PersistPactDb/Regression.hs

@@ -45,7 +45,7 @@ runRegression p = do
   let ks = KeySet [PublicKey "skdjhfskj"] (Name "predfun" def)
   _writeRow pactdb Write KeySets "ks1" ks v
   assertEquals' "keyset write" (Just ks) $ _readRow pactdb KeySets "ks1" v
-  let mod' = Module "mod1" "mod-admin-keyset" (Meta Nothing []) "code" (H.hash "code") mempty mempty mempty
+  let mod' = Module "mod1" "mod-admin-keyset" (Meta Nothing []) "code" (H.hash "code") mempty mempty mempty Nothing
   _writeRow pactdb Write Modules "mod1" mod' v
   assertEquals' "module write" (Just mod') $ _readRow pactdb Modules "mod1" v
   assertEquals' "result of commit 3"

src-ghc/Pact/Server/PactService.hs

@@ -153,7 +153,7 @@ applyContinuation rk msg@ContMsg{..} Command{..} = do
             Left (SomeException ex) -> throwM ex
             Right EvalResult{..} -> do
               exec@PactExec{..} <- maybe (throwCmdEx "No pact execution in continuation exec!")
-                                   return erExec         
+                                   return erExec
               if _cmRollback
                 then rollbackUpdate env msg state
                 else continuationUpdate env msg state pact exec
@@ -162,7 +162,7 @@ applyContinuation rk msg@ContMsg{..} Command{..} = do
 rollbackUpdate :: CommandEnv p -> ContMsg -> CommandState -> CommandM p ()
 rollbackUpdate CommandEnv{..} ContMsg{..} CommandState{..} = do
   -- if step doesn't have a rollback function, no error thrown. Therefore, pact will be deleted
-  -- from state. 
+  -- from state.
   let newState = CommandState _csRefStore $ M.delete _cmTxId _csPacts
   liftIO $ logLog _ceLogger "DEBUG" $ "applyContinuation: rollbackUpdate: reaping pact "
     ++ show _cmTxId
@@ -172,7 +172,7 @@ continuationUpdate :: CommandEnv p -> ContMsg -> CommandState -> CommandPact ->
 continuationUpdate CommandEnv{..} ContMsg{..} CommandState{..} CommandPact{..} PactExec{..} = do
   let nextStep = _cmStep + 1
       isLast = nextStep >= _cpStepCount
-      updateState pacts = CommandState _csRefStore pacts -- never loading modules during continuations 
+      updateState pacts = CommandState _csRefStore pacts -- never loading modules during continuations
 
   if isLast
     then do
@@ -183,4 +183,4 @@ continuationUpdate CommandEnv{..} ContMsg{..} CommandState{..} CommandPact{..} P
       let newPact = CommandPact _cpTxId _cpContinuation _cpStepCount _cmStep _peYield
       liftIO $ logLog _ceLogger "DEBUG" $ "applyContinuation: updated state of pact "
         ++ show _cmTxId ++ ": " ++ show newPact
-      void $ liftIO $ swapMVar _ceState $ updateState $ M.insert _cmTxId newPact _csPacts 
+      void $ liftIO $ swapMVar _ceState $ updateState $ M.insert _cmTxId newPact _csPacts

src/Pact/Compile.hs

@@ -21,13 +21,10 @@
 --
 
 module Pact.Compile
-    (
-     compile,compileExps
-    ,MkInfo,mkEmptyInfo,mkStringInfo,mkTextInfo
-    ,Reserved(..)
-    )
-
-where
+  ( compile,compileExps
+  , MkInfo,mkEmptyInfo,mkStringInfo,mkTextInfo
+  , Reserved(..)
+  ) where
 
 import qualified Text.Trifecta as TF hiding (expected)
 import Control.Applicative hiding (some,many)
@@ -75,13 +72,14 @@ initModuleState n h = ModuleState n h def def def
 data CompileState = CompileState
   { _csFresh :: Int
   , _csModule :: Maybe ModuleState
+  , _csNamespace :: Maybe NamespaceName
   }
 makeLenses ''CompileState
 
 type Compile a = ExpParse CompileState a
 
 initParseState :: Exp Info -> ParseState CompileState
-initParseState e = ParseState e $ CompileState 0 Nothing
+initParseState e = ParseState e $ CompileState 0 Nothing Nothing
 
 data Reserved =
     RBless
@@ -97,6 +95,7 @@ data Reserved =
   | RLet
   | RLetStar
   | RModule
+  | RNamespace
   | RStep
   | RStepWithRollback
   | RTrue
@@ -119,6 +118,7 @@ instance AsString Reserved where
     RLet -> "let"
     RLetStar -> "let*"
     RModule -> "module"
+    RNamespace -> "namespace"
     RStep -> "step"
     RStepWithRollback -> "step-with-rollback"
     RTrue -> "true"
@@ -198,7 +198,8 @@ topLevel = specialFormOrApp topLevelForm <|> literals <|> varAtom  where
     RLetStar -> return letsForm
     RModule -> return moduleForm
     RInterface -> return interface
-    _ -> expected "top-level form (use, let[*], module, interface)"
+    RNamespace -> return namespace
+    _ -> expected "top-level form (use, let[*], module, interface, namespace)"
 
 
 valueLevel :: Compile (Term Name)
@@ -239,7 +240,6 @@ userAtom = do
   pure a
 
 
-
 app :: Compile (Term Name)
 app = do
   v <- varAtom
@@ -411,14 +411,15 @@ moduleForm = do
     Just {} -> syntaxError "Invalid nested module or interface"
     Nothing -> return ()
   i <- contextInfo
+  namespaceName <- use (psUser . csNamespace)
   let code = case i of
         Info Nothing -> "<code unavailable>"
         Info (Just (c,_)) -> c
       modName = ModuleName modName'
       modHash = hash $ encodeUtf8 $ _unCode code
   ((bd,bi),ModuleState{..}) <- withModuleState (initModuleState modName modHash) $ bodyForm' moduleLevel
   return $ TModule
-    (Module modName (KeySetName keyset) m code modHash (HS.fromList _msBlessed) _msImplements _msImports)
+    (Module modName (KeySetName keyset) m code modHash (HS.fromList _msBlessed) _msImplements _msImports namespaceName)
     (abstract (const Nothing) (TList (concat bd) TyAny bi)) i
 
 implements :: Compile ()
@@ -434,6 +435,7 @@ interface = do
   use (psUser . csModule) >>= \ci -> case ci of
     Just {} -> syntaxError "invalid nested interface or module"
     Nothing -> return ()
+  namespaceName <- use (psUser . csNamespace)
   info <- contextInfo
   let code = case info of
         Info Nothing -> "<code unavailable>"
@@ -447,9 +449,20 @@ interface = do
               RUse -> return useForm
               t -> syntaxError $ "Invalid interface declaration: " ++ show (asString t)
   return $ TModule
-    (Interface iname code m _msImports)
+    (Interface iname code m _msImports namespaceName)
     (abstract (const Nothing) bd) info
 
+namespace :: Compile (Term Name)
+namespace = do
+  bareName <- _atomAtom <$> bareAtom
+  info <- contextInfo
+  let _nsName = NamespaceName bareName
+  use (psUser . csNamespace) >>= \case
+    Just ns -> syntaxError $ "A namespace has already been declared: " ++ asString' ns
+    Nothing -> pure ()
+  psUser . csNamespace .= (Just _nsName)
+  pure $ TNamespace _nsName info
+
 emptyDef :: Compile (Term Name)
 emptyDef = do
   modName <- currentModuleName

src/Pact/Eval.hs

@@ -87,8 +87,7 @@ evalCommitTx i = do
     Just {} -> commitTx i
 {-# INLINE evalCommitTx #-}
 
-
-enforceKeySetName ::  Info -> KeySetName ->  Eval e ()
+enforceKeySetName :: Info -> KeySetName -> Eval e ()
 enforceKeySetName mi mksn = do
   ks <- maybe (evalError mi $ "No such keyset: " ++ show mksn) return =<< readRow mi KeySets mksn
   runPure $ enforceKeySet mi (Just mksn) ks
@@ -174,6 +173,8 @@ revokeCapability c = evalCapabilities %= filter (/= c)
 eval ::  Term Name ->  Eval e (Term Name)
 eval (TUse u@Use{..} i) = topLevelCall i "use" (GUse _uModuleName _uModuleHash) $ \g ->
   evalUse u >> return (g,tStr $ pack $ "Using " ++ show _uModuleName)
+eval (TNamespace n info) = topLevelCall info "namespace" GNamespace $ \g ->
+  evalNamespace info n >> return (g, tStr . pack $ "Namespace " ++ asString' n)
 eval (TModule m@Module{} bod i) =
   topLevelCall i "module" (GModuleDecl m) $ \g0 -> do
     -- enforce old module keysets
@@ -226,6 +227,19 @@ evalUse (Use mn h i) = do
 
       installModule md
 
+evalNamespace :: Info -> NamespaceName -> Eval e ()
+evalNamespace info name = do
+  mOldNs <- use eeNamespace
+  case mOldNs of
+    Just (Namespace n _) ->
+      evalError info $ "Namespace already in use: " ++ asString' n
+    Nothing -> do
+      mNs <- readRow info Namespaces name
+      case mNs of
+        Nothing ->
+          evalError info $ "Namespace not defined: " ++ asString' name
+        ns      -> eeNamespace .= ns
+
 -- | Make table of module definitions for storage in namespace/RefStore.
 loadModule :: Module -> Scope n Term Name -> Info -> Gas -> Eval e (Gas,HM.HashMap Text (Term Name))
 loadModule m@Module{..} bod1 mi g0 = do
@@ -319,11 +333,10 @@ evaluateConstraints
 evaluateConstraints info Interface{} _ =
   evalError info "Unexpected: interface found in module position while solving constraints"
 evaluateConstraints info m evalMap =
-  -- we would like the lazy semantics of foldr to shortcircuit the solver
-  foldr evaluateConstraint (pure (m, evalMap)) (_mInterfaces m)
+  -- we would like the lazy semantics of foldM to shortcircuit the solver
+  foldM evaluateConstraint (m, evalMap) $ _mInterfaces m
   where
-    evaluateConstraint ifn em = do
-      (m',refMap) <- em
+    evaluateConstraint (m', refMap) ifn = do
       refData <- preview $ eeRefStore . rsModules . ix ifn
       case refData of
         Nothing -> evalError info $
@@ -356,16 +369,15 @@ solveConstraint info refName (Ref t) evalMap = do
     Just (Ref s) ->
       case (t, s) of
         (TDef (Def _n _mn dt (FunType args rty) _ m _) _,
-          TDef (Def _n' _mn' dt' (FunType args' rty') b m' i) _) -> do
+          TDef (Def _n' _mn' dt' (FunType args' rty') _ _ _) _) -> do
           when (dt /= dt') $ evalError info $ "deftypes mismatching: " ++ show dt ++ "\n" ++ show dt'
           when (rty /= rty') $ evalError info $ "return types mismatching: " ++ show rty ++ "\n" ++ show rty'
           when (length args /= length args') $ evalError info $ "mismatching argument lists: " ++ show args ++ "\n" ++ show args'
           forM_ (args `zip` args') $ \((Arg n ty _), (Arg n' ty' _)) -> do
             when (n /= n') $ evalError info $ "mismatching argument names: " ++ show n ++ " and " ++ show n'
             when (ty /= ty') $ evalError info $ "mismatching types: " ++ show ty ++ " and " ++ show ty'
-          -- the model concatenation step: we must reinsert the ref back into the map with new models
-          -- TODO yuck, should be lensing here
-          pure $ HM.insert refName (Ref $ TDef (Def _n' _mn' dt' (FunType args' rty') b (m <> m') i) i) em
+          -- the model concatenation step: we reinsert the ref back into the map with new models
+          pure $ HM.insert refName (Ref $ over (tDef . dMeta) (<> m) s) em
         _ -> evalError info $ "found overlapping const refs - please resolve: " ++ show t
 
 resolveRef :: Name -> Eval e (Maybe Ref)
@@ -430,6 +442,7 @@ reduce t@TUse {} = evalError (_tInfo t) "Use only allowed at top level"
 reduce t@TStep {} = evalError (_tInfo t) "Step at invalid location"
 reduce TSchema {..} = TSchema _tSchemaName _tModule _tMeta <$> traverse (traverse reduce) _tFields <*> pure _tInfo
 reduce TTable {..} = TTable _tTableName _tModule _tHash <$> mapM reduce _tTableType <*> pure _tMeta <*> pure _tInfo
+reduce t@TNamespace{} = unsafeReduce t
 
 mkDirect :: Term Name -> Term Ref
 mkDirect = (`TVar` def) . Direct

src/Pact/Native.hs

@@ -211,6 +211,35 @@ readDecimalDef = defRNative "read-decimal" readDecimal
       return $ toTerm a'
     readDecimal i as = argsError i as
 
+defineNamespaceDef :: NativeDef
+defineNamespaceDef = setTopLevelOnly $ defRNative "define-namespace" defineNamespace
+  (funType tTyString [("namespace", tTyString), ("guard", tTyGuard Nothing)])
+   "Create a namespace called NAMESPACE for a given GUARD. All expressions that occur \
+   \ in a given transaction will be tied to NAMESPACE, and may be accessed using the toplevel \
+   \ call (namespace NAMESPACE) when GUARD is in scope. If NAMESPACE is already defined, then \
+   \ the guard previously defined in NAMESPACE will be enforced, and GUARD will be rotated in \
+   \ its place. `(define-namespace 'my-namespace 'my-guard)`"
+  where
+    defineNamespace :: RNativeFun e
+    defineNamespace i as = case as of
+      [TLitString nsn, TGuard g _] -> go i nsn g
+      _ -> argsError i as
+
+    go fi nsn g = do
+      let name = NamespaceName nsn
+          info = _faInfo fi
+
+      mOldNs <- readRow info Namespaces name
+      case mOldNs of
+        Just (Namespace _ g') ->
+          -- if namespace is defined, enforce old guard and rotate
+          enforceGuard fi g' >> writeNamespace info name g
+        Nothing -> writeNamespace info name g
+
+    writeNamespace info n g =
+      writeRow info Write Namespaces n (Namespace n g)
+        & success "Namespace defined"
+
 
 langDefs :: NativeModule
 langDefs =
@@ -333,9 +362,9 @@ langDefs =
      "Lazily ignore arguments IGNORE* and return VALUE. `(filter (constantly true) [1 2 3])`"
     ,defRNative "identity" identity (funType a [("value",a)])
      "Return provided value. `(map (identity) [1 2 3])`"
-
     ,strToIntDef
     ,hashDef
+    ,defineNamespaceDef
     ])
     where b = mkTyVar "b" []
           c = mkTyVar "c" []

src/Pact/Native/Internal.hs

@@ -18,6 +18,7 @@ module Pact.Native.Internal
   (success
   ,parseMsgKey
   ,bindReduce
+  ,enforceGuard
   ,defNative,defGasRNative,defRNative
   ,setTopLevelOnly
   ,foldDefs
@@ -150,27 +151,26 @@ enforceGuardDef dn =
   where
     enforceGuard' :: RNativeFun e
     enforceGuard' i as = case as of
-      [TGuard g _] -> go g
-      [TLitString k] -> go (GKeySetRef (KeySetName k))
+      [TGuard g _] -> enforceGuard i g >> return (toTerm True)
+      [TLitString k] -> enforceGuard i (GKeySetRef (KeySetName k)) >> return (toTerm True)
       _ -> argsError i as
-      where
-        go g = runGuard g >> return (toTerm True)
-        runGuard g = case g of
-          GKeySet k -> runPure $ enforceKeySet (_faInfo i) Nothing k
-          GKeySetRef n -> enforceKeySetName (_faInfo i) n
-          GPact PactGuard{..} -> do
-            pid <- getPactId i
-            unless (pid == _pgPactId) $
-              evalError' i $
-                "Pact guard failed, intended: " ++ show _pgPactId ++ ", active: " ++ show pid
-          GModule mg@ModuleGuard{..} -> do
-            m <- getModule (_faInfo i) _mgModuleName
-            case m of
-              Module{..} -> enforceKeySetName (_faInfo i) _mKeySet
-              Interface{} -> evalError' i $ "ModuleGuard not allowed on interface: " ++ show mg
-          GUser UserGuard{..} -> do
-            void $ runReadOnly (_faInfo i) $
-              enscopeApply $ App (TVar _ugPredFun def) [_ugData] (_faInfo i)
+
+enforceGuard :: FunApp -> Guard -> Eval e ()
+enforceGuard i g = case g of
+  GKeySet k -> runPure $ enforceKeySet (_faInfo i) Nothing k
+  GKeySetRef n -> enforceKeySetName (_faInfo i) n
+  GPact PactGuard{..} -> do
+    pid <- getPactId i
+    unless (pid == _pgPactId) $
+      evalError' i $ "Pact guard failed, intended: " ++ show _pgPactId ++ ", active: " ++ show pid
+  GModule mg@ModuleGuard{..} -> do
+    m <- getModule (_faInfo i) _mgModuleName
+    case m of
+      Module{..} -> enforceKeySetName (_faInfo i) _mKeySet
+      Interface{} -> evalError' i $ "ModuleGuard not allowed on interface: " ++ show mg
+  GUser UserGuard{..} -> do
+    void $ runReadOnly (_faInfo i) $
+      enscopeApply $ App (TVar _ugPredFun def) [_ugData] (_faInfo i)
 
 findCallingModule :: Eval e (Maybe ModuleName)
 findCallingModule = uses evalCallStack (firstOf (traverse . sfApp . _Just . _1 . faModule . _Just))

src/Pact/Persist.hs

@@ -119,6 +119,7 @@ instance PactValue a => PactValue [a]
 instance PactValue Module
 instance PactValue KeySet
 instance PactValue Value
+instance PactValue Namespace
 
 data Persister s = Persister {
   createTable :: forall k . PactKey k => Table k -> Persist s ()