Chainweb-Pact SPV Support

chainweb.cabal

@@ -198,13 +198,14 @@ library
         , Chainweb.Pact.Backend.Types
         , Chainweb.Pact.BloomCache
         , Chainweb.Pact.PactService
+        , Chainweb.Pact.RestAPI
+        , Chainweb.Pact.RestAPI.Orphans
+        , Chainweb.Pact.RestAPI.Server
         , Chainweb.Pact.Service.BlockValidation
         , Chainweb.Pact.Service.PactInProcApi
         , Chainweb.Pact.Service.PactQueue
         , Chainweb.Pact.Service.Types
-        , Chainweb.Pact.RestAPI
-        , Chainweb.Pact.RestAPI.Orphans
-        , Chainweb.Pact.RestAPI.Server
+        , Chainweb.Pact.SPV
         , Chainweb.Pact.TransactionExec
         , Chainweb.Pact.Types
         , Chainweb.Pact.Utils
@@ -234,7 +235,7 @@ library
         , configuration-tools >= 0.4.1
         , connection >=0.2
         , containers >= 0.5
-        , cryptonite >=0.25
+        , cryptonite >= 0.25
         , data-default >=0.7
         , data-dword >= 0.3
         , deepseq >= 1.4

pact/coin-contract/coin.pact

@@ -1,14 +1,14 @@
 (module coin GOVERNANCE
 
-  "'coin' represents the Kadena Coin Contract."
+  "'coin' represents the Kadena Coin Contract. This contract provides both the \
+  \buy/redeem gas support in the form of 'fund-tx', as well as transfer,       \
+  \credit, debit, coinbase, account creation and query, as well as SPV burn    \
+  \create. To access the coin contract, you may use its fully-qualified name,  \
+  \or issue the '(use coin)' command in the body of a module declaration."
 
 
-  ; (implements coin-sig)
-  ; (implements spv-sig)
-
   ; --------------------------------------------------------------------------
   ; Schemas and Tables
-  ; --------------------------------------------------------------------------
 
   (defschema coin-schema
     balance:decimal
@@ -17,15 +17,16 @@
   (deftable coin-table:{coin-schema})
 
   (defschema creates-schema
-    exists:string
+    exists:bool
     )
   (deftable creates-table:{creates-schema})
 
   ; --------------------------------------------------------------------------
   ; Capabilities
-  ; --------------------------------------------------------------------------
 
-  (defcap GOVERNANCE () (enforce false "upgrade disabled"))
+  (defcap GOVERNANCE ()
+    "upgrade disabled"
+    false)
 
   (defcap TRANSFER ()
     "Autonomous capability to protect debit and credit actions"
@@ -49,7 +50,6 @@
 
   ; --------------------------------------------------------------------------
   ; Coin Contract
-  ; --------------------------------------------------------------------------
 
   (defun buy-gas:string (sender:string total:decimal)
     @doc "This function describes the main 'gas buy' operation. At this point \
@@ -62,7 +62,7 @@
 
     (require-capability (FUND_TX))
     (with-capability (TRANSFER)
-       (debit sender total))
+      (debit sender total))
     )
 
   (defun redeem-gas:string (miner:string miner-guard:guard sender:string total:decimal)
@@ -141,10 +141,6 @@
     (step (redeem-gas miner miner-guard sender total))
     )
 
-  ; --------------------------------------------------------------------------
-  ; Helpers
-  ; --------------------------------------------------------------------------
-
   (defun debit:string (account:string amount:decimal)
     @doc "Debit AMOUNT from ACCOUNT balance recording DATE and DATA"
 
@@ -168,54 +164,76 @@
     @model [(property (> amount 0.0))]
 
     (require-capability (TRANSFER))
-      (with-default-read coin-table account
-        { "balance" : 0.0, "guard" : guard }
-        { "balance" := balance, "guard" := retg }
-          ; we don't want to overwrite an existing guard with the user-supplied one
-        (enforce (= retg guard) "account guards do not match")
-
-        (write coin-table account
-          { "balance" : (+ balance amount)
-          , "guard"   : retg
-          }))
-      )
+    (with-default-read coin-table account
+      { "balance" : 0.0, "guard" : guard }
+      { "balance" := balance, "guard" := retg }
+      ; we don't want to overwrite an existing guard with the user-supplied one
+      (enforce (= retg guard)
+        "account guards do not match")
+
+      (write coin-table account
+        { "balance" : (+ balance amount)
+        , "guard"   : retg
+        })
+      ))
 
   (defun delete-coin (delete-account create-chain-id create-account create-account-guard quantity)
+    @doc "Burn QUANTITY-many coins for DELETE-ACCOUNT on the current chain, and \
+         \produce an SPV receipt which may be manually redeemed for an SPV      \
+         \proof. Once a proof is obtained, the user may call 'create-coin' and  \
+         \consume the proof on CREATE-CHAIN-ID, crediting CREATE-ACCOUNT        \
+         \QUANTITY-many coins."
+
+    @model [(property (> amount 0.0))]
+
     (with-capability (TRANSFER)
       (debit delete-account quantity)
+
       { "create-chain-id": create-chain-id
       , "create-account": create-account
       , "create-account-guard": create-account-guard
       , "quantity": quantity
-      , "delete-chain-id": (at "chain-id" (chain-data))
+      , "delete-block-height": (at 'block-height (chain-data))
+      , "delete-chain-id": (at 'chain-id (chain-data))
       , "delete-account": delete-account
       , "delete-tx-hash": (tx-hash)
-      }))
+      })
+    )
 
   (defun create-coin (proof)
-    (let ((outputs (at "outputs" (verify-spv "TXOUT" proof))))
-      (enforce (= 1 (length outputs)) "only one tx in outputs")
-      (bind (at 0 outputs)
+    @doc "Consume an SPV proof for a number of coins, and credit the account   \
+         \associated with the proof the quantify of coins burned on the source \
+         \chain by the burn account. Note: must be called on the correct chain \
+         \id as specified in the proof."
+
+    (let ((outputs (verify-spv "TXOUT" proof)))
+      (bind outputs
         { "create-chain-id":= create-chain-id
         , "create-account" := create-account
         , "create-account-guard" := create-account-guard
         , "quantity" := quantity
         , "delete-tx-hash" := delete-tx-hash
         , "delete-chain-id" := delete-chain-id
         }
-        (enforce (= (at "chain-id" (chain-data)) create-chain-id "enforce correct create chain ID"))
-        (let ((create-id (format "%:%" [delete-tx-hash delete-chain-id])))
-          (with-default-read create-id creates-table
+
+        (enforce
+          (= create-chain-id (at "chain-id" (chain-data)))
+          "enforce correct create chain ID")
+
+        (let ((create-id (format "{}:{}" [delete-tx-hash delete-chain-id])))
+          (with-default-read creates-table create-id
             { "exists": false }
             { "exists":= exists }
-            (enforce (not exists) (format "enforce unique usage of %" [create-id]))
+
+            (enforce (not exists)
+              (format "enforce unique usage of {}" [create-id]))
+
             (insert creates-table create-id { "exists": true })
+
             (with-capability (TRANSFER)
               (credit create-account create-account-guard quantity)))
           )))
     )
-
-
 )
 
 (create-table coin-table)

pact/coin-contract/spv-sig.pact

@@ -2,16 +2,17 @@
 
   "SPV support for the Kadena Coin Contract"
 
-  (defun delete-coin:string
+  (defun delete-coin
       ( delete-acct:string
-        create-chain-id:integer
-        create-account:string quantity:decimal )
+        create-chain-id:string
+        create-account:string
+        quantity:decimal )
 
     @doc "Produce an SPV receipt witnessing a cross-chain transfer from one account to another on a \
          \separate chain."
     )
 
-  (defun create-coin:string (proof create-account-guard:guard)
+  (defun create-coin:string (proof)
     @doc "Consume an SPV receipt witnessing a cross chain transfer from one account to another on a \
          \separate chain."
     )

src/Chainweb/Chainweb.hs

@@ -317,19 +317,19 @@ withChainwebInternal
     -> IO a
 withChainwebInternal conf logger peer rocksDb inner = do
     initializePayloadDb v payloadDb
-    cutMV <- newEmptyMVar
-    go mempty (toList cids) cutMV
+    cdbv <- newEmptyMVar
+    go mempty (toList cids) cdbv
   where
     payloadDb = newPayloadDb rocksDb
     chainLogger cid = addLabel ("chain", toText cid) logger
 
     -- Initialize chain resources
-    go cs (cid : t) mv =
-        withChainResources v cid rocksDb peer (chainLogger cid) mempoolConfig mv payloadDb $ \c ->
-            go (HM.insert cid c cs) t mv
+    go cs (cid : t) cdbv =
+        withChainResources v cid rocksDb peer (chainLogger cid) mempoolConfig cdbv payloadDb $ \c ->
+            go (HM.insert cid c cs) t cdbv
 
     -- Initialize global resources
-    go cs [] mv = do
+    go cs [] cdbv = do
         let webchain = mkWebBlockHeaderDb v (HM.map _chainResBlockHeaderDb cs)
             pact = mkWebPactExecutionService (HM.map _chainResPact cs)
             cutLogger = setComponent "cut" logger
@@ -355,7 +355,7 @@ withChainwebInternal conf logger peer rocksDb inner = do
                 }
 
             -- update the cutdb mvar used by pact service with cutdb
-            void $! putMVar mv mCutDb
+            void $! putMVar cdbv mCutDb
 
             withPactData cs cuts $ \pactData ->
                 withMinerResources mLogger mConf cwnid mCutDb $ \m ->

src/Chainweb/Chainweb/ChainResources.hs

@@ -118,9 +118,9 @@ withChainResources
     -> PayloadDb cas
     -> (ChainResources logger -> IO a)
     -> IO a
-withChainResources v cid rdb peer logger mempoolCfg mv payloadDb inner =
+withChainResources v cid rdb peer logger mempoolCfg cdbv payloadDb inner =
     Mempool.withInMemoryMempool mempoolCfg $ \mempool ->
-    withPactService v cid (setComponent "pact" logger) mempool mv $ \requestQ -> do
+    withPactService v cid (setComponent "pact" logger) mempool cdbv $ \requestQ -> do
     withBlockHeaderDb rdb v cid $ \cdb -> do
 
             -- replay pact

src/Chainweb/Cut/Test.hs

@@ -129,9 +129,9 @@ testMineWithPayload
     :: forall cas cid
     . HasChainId cid
     => PayloadCas cas
-    => Given WebBlockHeaderDb
-    => Given (PayloadDb cas)
-    => Nonce
+    => WebBlockHeaderDb
+    -> PayloadDb cas
+    -> Nonce
     -> HashTarget
     -> Time Int64
     -> PayloadWithOutputs
@@ -140,11 +140,11 @@ testMineWithPayload
     -> Cut
     -> PactExecutionService
     -> IO (Either MineFailure (T2 BlockHeader Cut))
-testMineWithPayload n target t payload nid i c pact =
+testMineWithPayload wbdb payloadDb n target t payload nid i c pact =
     forM (createNewCut n target t payloadHash nid i c) $ \p@(T2 h _) -> do
         validatePayload h payload
-        addNewPayload (given @(PayloadDb cas)) payload
-        insertWebBlockHeaderDb h
+        addNewPayload payloadDb payload
+        give wbdb (insertWebBlockHeaderDb h)
         return p
   where
     payloadHash = _payloadWithOutputsPayloadHash payload

src/Chainweb/CutDB.hs

@@ -42,6 +42,7 @@ module Chainweb.CutDB
 , CutDb
 , cutDbWebBlockHeaderDb
 , cutDbWebBlockHeaderStore
+, cutDbBlockHeaderDb
 , cutDbPayloadCas
 , cutDbPayloadStore
 , cutDbStore
@@ -226,6 +227,11 @@ cutDbWebBlockHeaderStore :: Getter (CutDb cas) WebBlockHeaderStore
 cutDbWebBlockHeaderStore = to _cutDbHeaderStore
 {-# INLINE cutDbWebBlockHeaderStore #-}
 
+-- | Access the blockerheaderdb via the cutdb for a given chain id
+--
+cutDbBlockHeaderDb :: HasChainId cid => cid -> Fold (CutDb cas) BlockHeaderDb
+cutDbBlockHeaderDb cid = cutDbWebBlockHeaderDb . ixg (_chainId cid)
+
 -- | Get the current 'Cut', which represent the latest chainweb state.
 --
 -- This the main API method of chainweb-consensus.

src/Chainweb/Miner/Test.hs

@@ -24,7 +24,6 @@ module Chainweb.Miner.Test ( testMiner ) where
 import Control.Concurrent (threadDelay)
 import Control.Lens (view, (^?!))
 
-import Data.Reflection (give)
 import qualified Data.Sequence as Seq
 import qualified Data.Text as T
 import Data.Tuple.Strict (T2(..), T3(..))
@@ -224,8 +223,7 @@ testMiner logFun conf nid cutDb = runForever logFun "Test Miner" $ do
         -- INVARIANT: `testMine` will succeed on the first attempt when
         -- POW is not used.
         --
-        result <- give payloadDb $ give wcdb
-            $ testMineWithPayload @cas (Nonce nonce) target ct payload nid cid c pact
+        result <- testMineWithPayload wcdb payloadDb (Nonce nonce) target ct payload nid cid c pact
 
         case result of
             Left BadNonce -> do