diff --git a/contract-benchmarks/ContractsBench.hs b/contract-benchmarks/ContractsBench.hs new file mode 100644 index 000000000..b1d1f5f58 --- /dev/null +++ b/contract-benchmarks/ContractsBench.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Data.Decimal +import Data.Text (Text) +import Data.Aeson +import Data.Default +import Control.Monad +import Criterion +import NeatInterpolation (text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import qualified Data.Set as S +import qualified Data.Map.Strict as M +import System.ProgressBar +import Pact.Types.Lang +import Pact.Interpreter +import System.FilePath +import System.Directory +import Pact.Types.RowData +import Pact.Parse +import Pact.Types.Names +import Pact.Compile +import Pact.PersistPactDb(DbEnv(..)) +import Pact.Types.Persistence +import Control.Exception +import Pact.Types.Runtime +import Pact.Types.Command +import Pact.JSON.Legacy.Value +import Pact.Types.SPV +import Pact.Gas +import Data.Functor (void) +import Pact.Bench +import Pact.Runtime.Utils +import Pact.Gas.Table +import qualified Pact.Eval as Eval + +import Control.DeepSeq +import Pact.Types.Logger +import Pact.GasModel.Types (NoopNFData) +import Pact.Types.Runtime (EvalEnv) +import Pact.Types.Capability +import Pact.Types.PactValue +import Control.Concurrent (readMVar) +import Pact.Persist.SQLite +import Pact.Types.Pretty +import Pact.Types.SQLite +import qualified System.Environment as Env +import Criterion.Main + +main :: IO () +main = do + v <- Env.lookupEnv "RESET_COIN_BENCH_DB" + defaultMain [allBenchmarks (v == Just "1")] + +data CoinBenchSenders + = CoinBenchSenderA + | CoinBenchSenderB + | CoinBenchSenderC + | CoinBenchSenderD + deriving Show + +getSender :: CoinBenchSenders -> String +getSender = drop 9 . show + +senderKeyA :: Text +senderKeyA = T.replicate 64 "a" +senderKeyB :: Text +senderKeyB = T.replicate 63 "a" <> "b" +senderKeyC :: Text +senderKeyC = T.replicate 63 "a" <> "c" +senderKeyD :: Text +senderKeyD = T.replicate 63 "a" <> "d" + + +pubKeyFromSenderRaw :: CoinBenchSenders -> Text +pubKeyFromSenderRaw = \case + CoinBenchSenderA -> senderKeyA + CoinBenchSenderB -> senderKeyB + CoinBenchSenderC -> senderKeyC + CoinBenchSenderD -> senderKeyD + +kColonFromSender :: CoinBenchSenders -> Text +kColonFromSender = ("k:" <>) . pubKeyFromSenderRaw + +pubKeyFromSender :: CoinBenchSenders -> PublicKeyText +pubKeyFromSender = PublicKeyText . pubKeyFromSenderRaw + + +getRightIO :: Exception e => Either e a -> IO a +getRightIO = either throwIO pure + +coinTransferTxRaw :: Text -> Text -> Text +coinTransferTxRaw sender receiver = + [text| (coin.transfer "$sender" "$receiver" 200.0) |] + +coinTransferCreateTxRaw :: Text -> Text -> Text -> Text +coinTransferCreateTxRaw sender receiver receiverKs = + [text| (coin.transfer-create "$sender" "$receiver" (read-keyset "$receiverKs") 200.0) |] + +loadCoinBenchModule :: FilePath -> PactDbEnv e -> IO (ModuleData Ref,PersistModuleData) +loadCoinBenchModule fp db = do + m <- T.readFile fp + pc <- parseCode m + let md = MsgData + (toLegacyJson $ object + [ "a" .= [pubKeyFromSenderRaw CoinBenchSenderA] + , "b" .= [pubKeyFromSenderRaw CoinBenchSenderB] + , "c" .= [pubKeyFromSenderRaw CoinBenchSenderC] + , "d" .= [pubKeyFromSenderRaw CoinBenchSenderD] + ]) + Nothing + pactInitialHash + [] + [] + let ec = ExecutionConfig $ S.fromList [FlagEnforceKeyFormats] + e <- setupEvalEnv db Nothing Transactional md (versionedNativesRefStore ec) + freeGasEnv permissiveNamespacePolicy noSPVSupport def ec + (r :: Either SomeException EvalResult) <- try $ evalExec defaultInterpreter e pc + void $ eitherDie "loadBenchModule (load)" $ either (Left . show) Right r + (benchMod,_) <- runEval def e $ getModule (def :: Info) (ModuleName "coin" Nothing) + p <- either (die "loadBenchModule" . show) (return $!) $ traverse (traverse toPersistDirect) benchMod + return (benchMod,p) + +coinBenchGasEnv :: GasEnv +coinBenchGasEnv = GasEnv (gasLimitToMilliGasLimit 300_000_000) 0.01 $ tableGasModel defaultGasConfig + +setupBenchEvalEnv :: PactDbEnv e -> MsgData -> IO (EvalEnv e) +setupBenchEvalEnv db md = do + let ec = ExecutionConfig $ S.fromList [FlagEnforceKeyFormats] + setupEvalEnv db Nothing Transactional md (versionedNativesRefStore ec) + coinBenchGasEnv permissiveNamespacePolicy noSPVSupport def ec + +newtype NoForce e + = NoForce e + +instance NFData (NoForce e) where + rnf _ = () + +transferCapFromSender :: CoinBenchSenders -> CoinBenchSenders -> Decimal -> SigCapability +transferCapFromSender sender receiver amount = + SigCapability (QualifiedName (ModuleName "coin" Nothing) "TRANSFER" def) + [ PLiteral (LString (kColonFromSender sender)) + , PLiteral (LString (kColonFromSender receiver)) + , PLiteral (LDecimal amount)] + +transferSigners :: CoinBenchSenders -> CoinBenchSenders -> Signer +transferSigners sender receiver = + Signer Nothing (pubKeyFromSenderRaw sender) Nothing [transferCapFromSender sender receiver 200] + + +runCoinTransferTx + :: PactDbEnv e + -> CoinBenchSenders + -> CoinBenchSenders + -> Benchmark +runCoinTransferTx db sender receiver = + bench title $ perRunEnvWithCleanup mkTerm doRollback $ \ ~(term, NoForce ee, es) -> + fst <$> runEval es ee (Eval.reduce term) + where + pdb = pdPactDb db + title = + "Coin transfer from " + <> getSender sender + <> " to " + <> getSender receiver + mkTerm = do + let md = MsgData + (toLegacyJson $ object []) + Nothing + pactInitialHash + [transferSigners sender receiver] + [] + ee <- setupBenchEvalEnv db md + () <$ _beginTx pdb Transactional (pdPactDbVar db) + let termText = coinTransferTxRaw (kColonFromSender sender) (kColonFromSender receiver) + -- note, we will return this eval state, as it definitely contains the loaded coin contract here. + [compiledTerm] <- compileExp termText + (term, es) <- runEval def ee (Eval.enscope compiledTerm) + pure (term, NoForce ee, es) + doRollback _ = do + _rollbackTx pdb (pdPactDbVar db) + +factorialNTXRaw :: Int -> Text +factorialNTXRaw n = + [text| (fold (*) 1 (enumerate 1 ${n'})) |] + where + n' = T.pack (show n) + +deepLetTXRaw :: Int -> Text +deepLetTXRaw n = + [text| (let* ($nestedLets) $lastVar) |] + where + initial = "(x1 1)" + nestedLets = T.concat $ initial : + [ [text| (x$ncurr (* $ncurr x${nprev})) |] | (prev, curr) <- zip [1..n] [2..n] + , let nprev = T.pack (show prev) + , let ncurr = T.pack (show curr)] + lastVar = "x" <> T.pack (show n) + +runPureBench + :: PactDbEnv e + -> String + -> Text + -> Benchmark +runPureBench db benchTitle termText = + bench benchTitle $ perRunEnvWithCleanup mkTerm doRollback $ \ ~(term, NoForce ee, es) -> + fst <$> runEval es ee (Eval.reduce term) + where + mkTerm = do + let md = MsgData + (toLegacyJson $ object []) + Nothing + pactInitialHash + [] + [] + ee <- setupBenchEvalEnv db md + -- note, we will return this eval state, as it definitely contains the loaded coin contract here. + [compiledTerm] <- compileExp termText + (term, es) <- runEval def ee (Eval.enscope compiledTerm) + pure (term, NoForce ee, es) + doRollback _ = pure () + +runCoinTransferTxWithNameReso + :: PactDbEnv e + -> CoinBenchSenders + -> CoinBenchSenders + -> Benchmark +runCoinTransferTxWithNameReso db sender receiver = + bench title $ perRunEnvWithCleanup mkTerm doRollback $ \ ~(term, NoForce ee) -> + fst <$> runEval def ee (Eval.eval term) + where + pdb = pdPactDb db + title = + "Coin transfer from " + <> getSender sender + <> " to " + <> getSender receiver + mkTerm = do + let md = MsgData + (toLegacyJson $ object []) + Nothing + pactInitialHash + [transferSigners sender receiver] + [] + ee <- setupBenchEvalEnv db md + () <$ _beginTx pdb Transactional (pdPactDbVar db) + let termText = coinTransferTxRaw (kColonFromSender sender) (kColonFromSender receiver) + -- note, we will return this eval state, as it definitely contains the loaded coin contract here. + [compiledTerm] <- compileExp termText + pure (compiledTerm, NoForce ee) + doRollback _ = do + _rollbackTx pdb (pdPactDbVar db) + +coinTableName :: TableName +coinTableName = TableName "coin_coin-table" + +prePopulateCoinEntries :: PactDbEnv e -> IO () +prePopulateCoinEntries pdb = do + let style = defStyle {stylePrefix = msg "Pre-filling the coin table"} + putStrLn "Setting up the coin table" + pbar <- newProgressBar style 10 (Progress 0 100_0 ()) + forM_ [1 :: Integer .. 100_0] $ \i -> do + let n = renderCompactText $ pactHash $ T.encodeUtf8 $ T.pack (show i) + writeBench pdb Write (UserTables coinTableName) (RowKey n) (RowData RDV1 (obj n)) + incProgress pbar 1 + where + obj n = ObjectMap $ M.fromList + [(FieldKey "balance", RDLiteral $ LDecimal 100) + , (FieldKey "guard" + , RDGuard (GKeySet (KeySet (S.singleton (PublicKeyText n)) (Name (BareName "keys-all" def))))) + ] + + +benchmarkSqliteFile :: String +benchmarkSqliteFile = "core-benches.sqlite" + +beginTxBench :: PactDbEnv e -> IO (Maybe TxId) +beginTxBench dbe = + _beginTx (pdPactDb dbe) Transactional (pdPactDbVar dbe) + +commitTxBench :: PactDbEnv e -> IO [TxLogJson] +commitTxBench dbe = + _commitTx (pdPactDb dbe) (pdPactDbVar dbe) + +rollbackTxBench :: PactDbEnv e -> IO () +rollbackTxBench dbe = + _rollbackTx (pdPactDb dbe) (pdPactDbVar dbe) + +writeBench dbe wt domain k v = + _writeRow (pdPactDb dbe) wt domain k v (pdPactDbVar dbe) + +contractsPath :: FilePath +contractsPath = "contract-benchmarks" "contracts" + +allBenchmarks :: Bool -> Benchmark +allBenchmarks resetDb = + envWithCleanup mkPactDb cleanupPactDb $ \ ~(NoForce pdb) -> + bgroup "Coin benches" + [ + runPureBench pdb "factorial 1000" (factorialNTXRaw 1000) + , runPureBench pdb "Let 100" (deepLetTXRaw 100) + , runPureBench pdb "Let 1000" (deepLetTXRaw 1000) + , runPureBench pdb "Let 10000" (deepLetTXRaw 10000) + -- coinTransferBenches pdb + ] + where + cleanupSqlite sqliteDb = do + c <- readMVar $ pdPactDbVar sqliteDb + void $ closeSQLite $ _db c + coinTransferBenches pdb = + bgroup "transfer benchmarks" + [ runCoinTransferTx pdb CoinBenchSenderA CoinBenchSenderB + , runCoinTransferTxWithNameReso pdb CoinBenchSenderA CoinBenchSenderB + ] + mkPactDb = do + c <- doesFileExist benchmarkSqliteFile + when (c && resetDb) $ removeFile benchmarkSqliteFile + db <- mkSQLiteEnv (newLogger neverLog "") True (SQLiteConfig benchmarkSqliteFile fastNoJournalPragmas) neverLog + initSchema db + _ <- loadCoinBenchModule (contractsPath "coin-v5-create.pact") db + _ <- beginTxBench db + when resetDb $ prePopulateCoinEntries db + _ <- commitTxBench db + pure (NoForce db) + cleanupPactDb (NoForce db) = + cleanupSqlite db + diff --git a/contract-benchmarks/contracts/coin-v5-create.pact b/contract-benchmarks/contracts/coin-v5-create.pact new file mode 100644 index 000000000..1df258be6 --- /dev/null +++ b/contract-benchmarks/contracts/coin-v5-create.pact @@ -0,0 +1,864 @@ +(interface fungible-xchain-v1 + + " This interface offers a standard capability for cross-chain \ + \ transfers and associated events. " + + (defcap TRANSFER_XCHAIN:bool + ( sender:string + receiver:string + amount:decimal + target-chain:string + ) + @doc " Managed capability sealing AMOUNT for transfer \ + \ from SENDER to RECEIVER on TARGET-CHAIN. Permits \ + \ any number of cross-chain transfers up to AMOUNT." + + @managed amount TRANSFER_XCHAIN-mgr + ) + + (defun TRANSFER_XCHAIN-mgr:decimal + ( managed:decimal + requested:decimal + ) + @doc " Allows TRANSFER-XCHAIN AMOUNT to be less than or \ + \ equal managed quantity as a one-shot, returning 0.0." + ) + + (defcap TRANSFER_XCHAIN_RECD:bool + ( sender:string + receiver:string + amount:decimal + source-chain:string + ) + @doc "Event emitted on receipt of cross-chain transfer." + @event + ) +) + + +(interface fungible-v2 + + " Standard for fungible coins and tokens as specified in KIP-0002. " + + ; ---------------------------------------------------------------------- + ; Schema + + (defschema account-details + @doc "Schema for results of 'account' operation." + @model [ (invariant (!= "" sender)) ] + + account:string + balance:decimal + guard:guard) + + + ; ---------------------------------------------------------------------- + ; Caps + + (defcap TRANSFER:bool + ( sender:string + receiver:string + amount:decimal + ) + @doc " Managed capability sealing AMOUNT for transfer from SENDER to \ + \ RECEIVER. Permits any number of transfers up to AMOUNT." + @managed amount TRANSFER-mgr + ) + + (defun TRANSFER-mgr:decimal + ( managed:decimal + requested:decimal + ) + @doc " Manages TRANSFER AMOUNT linearly, \ + \ such that a request for 1.0 amount on a 3.0 \ + \ managed quantity emits updated amount 2.0." + ) + + ; ---------------------------------------------------------------------- + ; Functionality + + + (defun transfer:string + ( sender:string + receiver:string + amount:decimal + ) + @doc " Transfer AMOUNT between accounts SENDER and RECEIVER. \ + \ Fails if either SENDER or RECEIVER does not exist." + @model [ (property (> amount 0.0)) + (property (!= sender "")) + (property (!= receiver "")) + (property (!= sender receiver)) + ] + ) + + (defun transfer-create:string + ( sender:string + receiver:string + receiver-guard:guard + amount:decimal + ) + @doc " Transfer AMOUNT between accounts SENDER and RECEIVER. \ + \ Fails if SENDER does not exist. If RECEIVER exists, guard \ + \ must match existing value. If RECEIVER does not exist, \ + \ RECEIVER account is created using RECEIVER-GUARD. \ + \ Subject to management by TRANSFER capability." + @model [ (property (> amount 0.0)) + (property (!= sender "")) + (property (!= receiver "")) + (property (!= sender receiver)) + ] + ) + + (defpact transfer-crosschain:string + ( sender:string + receiver:string + receiver-guard:guard + target-chain:string + amount:decimal + ) + @doc " 2-step pact to transfer AMOUNT from SENDER on current chain \ + \ to RECEIVER on TARGET-CHAIN via SPV proof. \ + \ TARGET-CHAIN must be different than current chain id. \ + \ First step debits AMOUNT coins in SENDER account and yields \ + \ RECEIVER, RECEIVER_GUARD and AMOUNT to TARGET-CHAIN. \ + \ Second step continuation is sent into TARGET-CHAIN with proof \ + \ obtained from the spv 'output' endpoint of Chainweb. \ + \ Proof is validated and RECEIVER is credited with AMOUNT \ + \ creating account with RECEIVER_GUARD as necessary." + @model [ (property (> amount 0.0)) + (property (!= sender "")) + (property (!= receiver "")) + (property (!= sender receiver)) + (property (!= target-chain "")) + ] + ) + + (defun get-balance:decimal + ( account:string ) + " Get balance for ACCOUNT. Fails if account does not exist." + ) + + (defun details:object{account-details} + ( account: string ) + " Get an object with details of ACCOUNT. \ + \ Fails if account does not exist." + ) + + (defun precision:integer + () + "Return the maximum allowed decimal precision." + ) + + (defun enforce-unit:bool + ( amount:decimal ) + " Enforce minimum precision allowed for transactions." + ) + + (defun create-account:string + ( account:string + guard:guard + ) + " Create ACCOUNT with 0.0 balance, with GUARD controlling access." + ) + + (defun rotate:string + ( account:string + new-guard:guard + ) + " Rotate guard for ACCOUNT. Transaction is validated against \ + \ existing guard before installing new guard. " + ) + +) + + +(module coin GOVERNANCE + + @doc "'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." + + @model + [ (defproperty conserves-mass + (= (column-delta coin-table 'balance) 0.0)) + + (defproperty valid-account (account:string) + (and + (>= (length account) 3) + (<= (length account) 256))) + ] + + (implements fungible-v2) + (implements fungible-xchain-v1) + + ;; coin-v2 + (bless "ut_J_ZNkoyaPUEJhiwVeWnkSQn9JT9sQCWKdjjVVrWo") + + ;; coin v3 + (bless "1os_sLAUYvBzspn5jjawtRpJWiH1WPfhyNraeVvSIwU") + + ;; coin v4 + (bless "BjZW0T2ac6qE_I5X8GE4fal6tTqjhLTC7my0ytQSxLU") + + ; -------------------------------------------------------------------------- + ; Schemas and Tables + + (defschema coin-schema + @doc "The coin contract token schema" + @model [ (invariant (>= balance 0.0)) ] + + balance:decimal + guard:guard) + + (deftable coin-table:{coin-schema}) + + ; -------------------------------------------------------------------------- + ; Capabilities + + (defcap GOVERNANCE () + (enforce false "Enforce non-upgradeability")) + + (defcap GAS () + "Magic capability to protect gas buy and redeem" + true) + + (defcap COINBASE () + "Magic capability to protect miner reward" + true) + + (defcap GENESIS () + "Magic capability constraining genesis transactions" + true) + + (defcap REMEDIATE () + "Magic capability for remediation transactions" + true) + + (defcap DEBIT (sender:string) + "Capability for managing debiting operations" + (enforce-guard (at 'guard (read coin-table sender))) + (enforce (!= sender "") "valid sender")) + + (defcap CREDIT (receiver:string) + "Capability for managing crediting operations" + (enforce (!= receiver "") "valid receiver")) + + (defcap ROTATE (account:string) + @doc "Autonomously managed capability for guard rotation" + @managed + true) + + (defcap TRANSFER:bool + ( sender:string + receiver:string + amount:decimal + ) + @managed amount TRANSFER-mgr + (enforce (!= sender receiver) "same sender and receiver") + (enforce-unit amount) + (enforce (> amount 0.0) "Positive amount") + (compose-capability (DEBIT sender)) + (compose-capability (CREDIT receiver)) + ) + + (defun TRANSFER-mgr:decimal + ( managed:decimal + requested:decimal + ) + + (let ((newbal (- managed requested))) + (enforce (>= newbal 0.0) + (format "TRANSFER exceeded for balance {}" [managed])) + newbal) + ) + + (defcap TRANSFER_XCHAIN:bool + ( sender:string + receiver:string + amount:decimal + target-chain:string + ) + + @managed amount TRANSFER_XCHAIN-mgr + (enforce-unit amount) + (enforce (> amount 0.0) "Cross-chain transfers require a positive amount") + (compose-capability (DEBIT sender)) + ) + + (defun TRANSFER_XCHAIN-mgr:decimal + ( managed:decimal + requested:decimal + ) + + (enforce (>= managed requested) + (format "TRANSFER_XCHAIN exceeded for balance {}" [managed])) + 0.0 + ) + + (defcap TRANSFER_XCHAIN_RECD:bool + ( sender:string + receiver:string + amount:decimal + source-chain:string + ) + @event true + ) + + ; v3 capabilities + (defcap RELEASE_ALLOCATION + ( account:string + amount:decimal + ) + @doc "Event for allocation release, can be used for sig scoping." + @event true + ) + + ; -------------------------------------------------------------------------- + ; Constants + + (defconst COIN_CHARSET CHARSET_LATIN1 + "The default coin contract character set") + + (defconst MINIMUM_PRECISION 12 + "Minimum allowed precision for coin transactions") + + (defconst MINIMUM_ACCOUNT_LENGTH 3 + "Minimum account length admissible for coin accounts") + + (defconst MAXIMUM_ACCOUNT_LENGTH 256 + "Maximum account name length admissible for coin accounts") + + (defconst VALID_CHAIN_IDS (map (int-to-str 10) (enumerate 0 19)) + "List of all valid Chainweb chain ids") + + ; -------------------------------------------------------------------------- + ; Utilities + + (defun enforce-unit:bool (amount:decimal) + @doc "Enforce minimum precision allowed for coin transactions" + + (enforce + (= (floor amount MINIMUM_PRECISION) + amount) + (format "Amount violates minimum precision: {}" [amount])) + ) + + (defun validate-account (account:string) + @doc "Enforce that an account name conforms to the coin contract \ + \minimum and maximum length requirements, as well as the \ + \latin-1 character set." + + (enforce + (is-charset COIN_CHARSET account) + (format + "Account does not conform to the coin contract charset: {}" + [account])) + + (let ((account-length (length account))) + + (enforce + (>= account-length MINIMUM_ACCOUNT_LENGTH) + (format + "Account name does not conform to the min length requirement: {}" + [account])) + + (enforce + (<= account-length MAXIMUM_ACCOUNT_LENGTH) + (format + "Account name does not conform to the max length requirement: {}" + [account])) + ) + ) + + ; -------------------------------------------------------------------------- + ; Coin Contract + + (defun gas-only () + "Predicate for gas-only user guards." + (require-capability (GAS))) + + (defun gas-guard (guard:guard) + "Predicate for gas + single key user guards" + (enforce-one + "Enforce either the presence of a GAS cap or keyset" + [ (gas-only) + (enforce-guard guard) + ])) + + (defun buy-gas:string (sender:string total:decimal) + @doc "This function describes the main 'gas buy' operation. At this point \ + \MINER has been chosen from the pool, and will be validated. The SENDER \ + \of this transaction has specified a gas limit LIMIT (maximum gas) for \ + \the transaction, and the price is the spot price of gas at that time. \ + \The gas buy will be executed prior to executing SENDER's code." + + @model [ (property (> total 0.0)) + (property (valid-account sender)) + ] + + (validate-account sender) + + (enforce-unit total) + (enforce (> total 0.0) "gas supply must be a positive quantity") + + (require-capability (GAS)) + (with-capability (DEBIT sender) + (debit sender total)) + ) + + (defun redeem-gas:string (miner:string miner-guard:guard sender:string total:decimal) + @doc "This function describes the main 'redeem gas' operation. At this \ + \point, the SENDER's transaction has been executed, and the gas that \ + \was charged has been calculated. MINER will be credited the gas cost, \ + \and SENDER will receive the remainder up to the limit" + + @model [ (property (> total 0.0)) + (property (valid-account sender)) + (property (valid-account miner)) + ] + + (validate-account sender) + (validate-account miner) + (enforce-unit total) + + (require-capability (GAS)) + (let* + ((fee (read-decimal "fee")) + (refund (- total fee))) + + (enforce-unit fee) + (enforce (>= fee 0.0) + "fee must be a non-negative quantity") + + (enforce (>= refund 0.0) + "refund must be a non-negative quantity") + + (emit-event (TRANSFER sender miner fee)) ;v3 + + ; directly update instead of credit + (with-capability (CREDIT sender) + (if (> refund 0.0) + (with-read coin-table sender + { "balance" := balance } + (update coin-table sender + { "balance": (+ balance refund) })) + + "noop")) + + (with-capability (CREDIT miner) + (if (> fee 0.0) + (credit miner miner-guard fee) + "noop")) + ) + + ) + + (defun create-account:string (account:string guard:guard) + @model [ (property (valid-account account)) ] + + (validate-account account) + (enforce-reserved account guard) + + (insert coin-table account + { "balance" : 0.0 + , "guard" : guard + }) + ) + + (defun get-balance:decimal (account:string) + (with-read coin-table account + { "balance" := balance } + balance + ) + ) + + (defun details:object{fungible-v2.account-details} + ( account:string ) + (with-read coin-table account + { "balance" := bal + , "guard" := g } + { "account" : account + , "balance" : bal + , "guard": g }) + ) + + (defun rotate:string (account:string new-guard:guard) + (with-capability (ROTATE account) + (with-read coin-table account + { "guard" := old-guard } + + (enforce-guard old-guard) + + (update coin-table account + { "guard" : new-guard } + ))) + ) + + + (defun precision:integer + () + MINIMUM_PRECISION) + + (defun transfer:string (sender:string receiver:string amount:decimal) + @model [ (property conserves-mass) + (property (> amount 0.0)) + (property (valid-account sender)) + (property (valid-account receiver)) + (property (!= sender receiver)) ] + + (enforce (!= sender receiver) + "sender cannot be the receiver of a transfer") + + (validate-account sender) + (validate-account receiver) + + (enforce (> amount 0.0) + "transfer amount must be positive") + + (enforce-unit amount) + + (with-capability (TRANSFER sender receiver amount) + (debit sender amount) + (with-read coin-table receiver + { "guard" := g } + + (credit receiver g amount)) + ) + ) + + (defun transfer-create:string + ( sender:string + receiver:string + receiver-guard:guard + amount:decimal ) + + @model [ (property conserves-mass) ] + + (enforce (!= sender receiver) + "sender cannot be the receiver of a transfer") + + (validate-account sender) + (validate-account receiver) + + (enforce (> amount 0.0) + "transfer amount must be positive") + + (enforce-unit amount) + + (with-capability (TRANSFER sender receiver amount) + (debit sender amount) + (credit receiver receiver-guard amount)) + ) + + (defun coinbase:string (account:string account-guard:guard amount:decimal) + @doc "Internal function for the initial creation of coins. This function \ + \cannot be used outside of the coin contract." + + @model [ (property (valid-account account)) + (property (> amount 0.0)) + ] + + (validate-account account) + (enforce-unit amount) + + (require-capability (COINBASE)) + (emit-event (TRANSFER "" account amount)) ;v3 + (with-capability (CREDIT account) + (credit account account-guard amount)) + ) + + (defun remediate:string (account:string amount:decimal) + @doc "Allows for remediation transactions. This function \ + \is protected by the REMEDIATE capability" + @model [ (property (valid-account account)) + (property (> amount 0.0)) + ] + + (validate-account account) + + (enforce (> amount 0.0) + "Remediation amount must be positive") + + (enforce-unit amount) + + (require-capability (REMEDIATE)) + (emit-event (TRANSFER "" account amount)) ;v3 + (with-read coin-table account + { "balance" := balance } + + (enforce (<= amount balance) "Insufficient funds") + + (update coin-table account + { "balance" : (- balance amount) } + )) + ) + + (defpact fund-tx (sender:string miner:string miner-guard:guard total:decimal) + @doc "'fund-tx' is a special pact to fund a transaction in two steps, \ + \with the actual transaction transpiring in the middle: \ + \ \ + \ 1) A buying phase, debiting the sender for total gas and fee, yielding \ + \ TX_MAX_CHARGE. \ + \ 2) A settlement phase, resuming TX_MAX_CHARGE, and allocating to the \ + \ coinbase account for used gas and fee, and sender account for bal- \ + \ ance (unused gas, if any)." + + @model [ (property (> total 0.0)) + (property (valid-account sender)) + (property (valid-account miner)) + ;(property conserves-mass) not supported yet + ] + + (step (buy-gas sender total)) + (step (redeem-gas miner miner-guard sender total)) + ) + + (defun debit:string (account:string amount:decimal) + @doc "Debit AMOUNT from ACCOUNT balance" + + @model [ (property (> amount 0.0)) + (property (valid-account account)) + ] + + (validate-account account) + + (enforce (> amount 0.0) + "debit amount must be positive") + + (enforce-unit amount) + + (require-capability (DEBIT account)) + (with-read coin-table account + { "balance" := balance } + + (enforce (<= amount balance) "Insufficient funds") + + (update coin-table account + { "balance" : (- balance amount) } + )) + ) + + + (defun credit:string (account:string guard:guard amount:decimal) + @doc "Credit AMOUNT to ACCOUNT balance" + + @model [ (property (> amount 0.0)) + (property (valid-account account)) + ] + + (validate-account account) + + (enforce (> amount 0.0) "credit amount must be positive") + (enforce-unit amount) + + (require-capability (CREDIT account)) + (with-default-read coin-table account + { "balance" : -1.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") + + (let ((is-new + (if (= balance -1.0) + (enforce-reserved account guard) + false))) + + (write coin-table account + { "balance" : (if is-new amount (+ balance amount)) + , "guard" : retg + })) + )) + + (defun check-reserved:string (account:string) + " Checks ACCOUNT for reserved name and returns type if \ + \ found or empty string. Reserved names start with a \ + \ single char and colon, e.g. 'c:foo', which would return 'c' as type." + (let ((pfx (take 2 account))) + (if (= ":" (take -1 pfx)) (take 1 pfx) ""))) + + (defun enforce-reserved:bool (account:string guard:guard) + @doc "Enforce reserved account name protocols." + (if (validate-principal guard account) + true + (let ((r (check-reserved account))) + (if (= r "") + true + (if (= r "k") + (enforce false "Single-key account protocol violation") + (enforce false + (format "Reserved protocol guard violation: {}" [r])) + ))))) + + + (defschema crosschain-schema + @doc "Schema for yielded value in cross-chain transfers" + receiver:string + receiver-guard:guard + amount:decimal + source-chain:string) + + (defpact transfer-crosschain:string + ( sender:string + receiver:string + receiver-guard:guard + target-chain:string + amount:decimal ) + + @model [ (property (> amount 0.0)) + (property (valid-account sender)) + (property (valid-account receiver)) + ] + + (step + (with-capability + (TRANSFER_XCHAIN sender receiver amount target-chain) + + (validate-account sender) + (validate-account receiver) + + (enforce (!= "" target-chain) "empty target-chain") + (enforce (!= (at 'chain-id (chain-data)) target-chain) + "cannot run cross-chain transfers to the same chain") + + (enforce (> amount 0.0) + "transfer quantity must be positive") + + (enforce-unit amount) + + (enforce (contains target-chain VALID_CHAIN_IDS) + "target chain is not a valid chainweb chain id") + + ;; step 1 - debit delete-account on current chain + (debit sender amount) + (emit-event (TRANSFER sender "" amount)) + + (let + ((crosschain-details:object{crosschain-schema} + { "receiver" : receiver + , "receiver-guard" : receiver-guard + , "amount" : amount + , "source-chain" : (at 'chain-id (chain-data)) + })) + (yield crosschain-details target-chain) + ))) + + (step + (resume + { "receiver" := receiver + , "receiver-guard" := receiver-guard + , "amount" := amount + , "source-chain" := source-chain + } + + (emit-event (TRANSFER "" receiver amount)) + (emit-event (TRANSFER_XCHAIN_RECD "" receiver amount source-chain)) + + ;; step 2 - credit create account on target chain + (with-capability (CREDIT receiver) + (credit receiver receiver-guard amount)) + )) + ) + + + ; -------------------------------------------------------------------------- + ; Coin allocations + + (defschema allocation-schema + @doc "Genesis allocation registry" + ;@model [ (invariant (>= balance 0.0)) ] + + balance:decimal + date:time + guard:guard + redeemed:bool) + + (deftable allocation-table:{allocation-schema}) + + (defun create-allocation-account + ( account:string + date:time + keyset-ref:string + amount:decimal + ) + + @doc "Add an entry to the coin allocation table. This function \ + \also creates a corresponding empty coin contract account \ + \of the same name and guard. Requires GENESIS capability. " + + @model [ (property (valid-account account)) ] + + (require-capability (GENESIS)) + + (validate-account account) + (enforce (>= amount 0.0) + "allocation amount must be non-negative") + + (enforce-unit amount) + + (let + ((guard:guard (keyset-ref-guard keyset-ref))) + + (create-account account guard) + + (insert allocation-table account + { "balance" : amount + , "date" : date + , "guard" : guard + , "redeemed" : false + }))) + + (defun release-allocation + ( account:string ) + + @doc "Release funds associated with allocation ACCOUNT into main ledger. \ + \ACCOUNT must already exist in main ledger. Allocation is deactivated \ + \after release." + @model [ (property (valid-account account)) ] + + (validate-account account) + + (with-read allocation-table account + { "balance" := balance + , "date" := release-time + , "redeemed" := redeemed + , "guard" := guard + } + + (let ((curr-time:time (at 'block-time (chain-data)))) + + (enforce (not redeemed) + "allocation funds have already been redeemed") + + (enforce + (>= curr-time release-time) + (format "funds locked until {}. current time: {}" [release-time curr-time])) + + (with-capability (RELEASE_ALLOCATION account balance) + + (enforce-guard guard) + + (with-capability (CREDIT account) + (emit-event (TRANSFER "" account balance)) + (credit account guard balance) + + (update allocation-table account + { "redeemed" : true + , "balance" : 0.0 + }) + + "Allocation successfully released to main ledger")) + ))) + +) + + +(create-table coin-table) +(create-table allocation-table) +(write coin-table "k:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" {"balance":100000.0, "guard":(read-keyset "a")}) +(write coin-table "k:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab" {"balance":100000.0, "guard":(read-keyset "b")}) +; (write coin-table "k:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaac" {"balance":100000.0, "guard":(read-keyset "c")}) +; (write coin-table "k:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaad" {"balance":100000.0, "guard":(read-keyset "d")}) diff --git a/pact.cabal b/pact.cabal index 84b61c365..edd3cc0cb 100644 --- a/pact.cabal +++ b/pact.cabal @@ -387,6 +387,31 @@ executable gasmodel ghc-prof-options: -fprof-auto -fprof-auto-calls default-language: Haskell2010 +executable contracts-bench + main-is: ContractsBench.hs + build-depends: base + , pact + , text + , criterion + , containers + , lens + , neat-interpolation + , terminal-progress-bar + , direct-sqlite + , mtl + , unordered-containers + , pact-json + , aeson + , data-default + , deepseq + , Decimal + , directory + , filepath + hs-source-dirs: contract-benchmarks + ghc-options: -Wall -threaded -rtsopts -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + ghc-prof-options: -fprof-auto -fprof-auto-calls + default-language: Haskell2010 + benchmark bench-json if !flag(build-tool) buildable: False diff --git a/src/Pact/Eval.hs b/src/Pact/Eval.hs index 08ce3271a..6311e437f 100644 --- a/src/Pact/Eval.hs +++ b/src/Pact/Eval.hs @@ -50,6 +50,7 @@ module Pact.Eval ,resumeNestedPactExec ,createNestedPactId ,getSizeOfVersion + ,enscope ) where import Bound diff --git a/src/Pact/Types/Command.hs b/src/Pact/Types/Command.hs index 92d435908..86c134016 100644 --- a/src/Pact/Types/Command.hs +++ b/src/Pact/Types/Command.hs @@ -18,7 +18,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Pact.Types.Command diff --git a/src/Pact/Types/Crypto.hs b/src/Pact/Types/Crypto.hs index 1206756ea..5528dbab9 100644 --- a/src/Pact/Types/Crypto.hs +++ b/src/Pact/Types/Crypto.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} @@ -483,29 +482,29 @@ ed25519GenKeyPair = do ed25519GetPublicKey :: Ed25519.SecretKey -> Ed25519.PublicKey ed25519GetPublicKey = Ed25519.toPublic -instance Ord Ed25519.PublicKey where - b <= b' = (B.convert b :: ByteString) <= (B.convert b' :: ByteString) -instance Serialize Ed25519.PublicKey where - put s = S.putByteString (B.convert s :: ByteString) - get = maybe (fail "Invalid ED25519 Public Key") return =<< - (E.maybeCryptoError . Ed25519.publicKey <$> S.getByteString 32) +-- instance Ord Ed25519.PublicKey where +-- b <= b' = (B.convert b :: ByteString) <= (B.convert b' :: ByteString) +-- instance Serialize Ed25519.PublicKey where +-- put s = S.putByteString (B.convert s :: ByteString) +-- get = maybe (fail "Invalid ED25519 Public Key") return =<< +-- (E.maybeCryptoError . Ed25519.publicKey <$> S.getByteString 32) -instance Ord Ed25519.SecretKey where - b <= b' = (B.convert b :: ByteString) <= (B.convert b' :: ByteString) -instance Serialize Ed25519.SecretKey where - put s = S.putByteString (B.convert s :: ByteString) - get = maybe (fail "Invalid ED25519 Private Key") return =<< - (E.maybeCryptoError . Ed25519.secretKey <$> S.getByteString 32) +-- instance Ord Ed25519.SecretKey where +-- b <= b' = (B.convert b :: ByteString) <= (B.convert b' :: ByteString) +-- instance Serialize Ed25519.SecretKey where +-- put s = S.putByteString (B.convert s :: ByteString) +-- get = maybe (fail "Invalid ED25519 Private Key") return =<< +-- (E.maybeCryptoError . Ed25519.secretKey <$> S.getByteString 32) -instance Ord Ed25519.Signature where - b <= b' = (B.convert b :: ByteString) <= (B.convert b' :: ByteString) -instance Serialize Ed25519.Signature where - put s = S.put (B.convert s :: ByteString) - get = maybe (fail "Invalide ED25519 Signature") return =<< - (E.maybeCryptoError . Ed25519.signature <$> (S.get >>= S.getByteString)) +-- instance Ord Ed25519.Signature where +-- b <= b' = (B.convert b :: ByteString) <= (B.convert b' :: ByteString) +-- instance Serialize Ed25519.Signature where +-- put s = S.put (B.convert s :: ByteString) +-- get = maybe (fail "Invalide ED25519 Signature") return =<< +-- (E.maybeCryptoError . Ed25519.signature <$> (S.get >>= S.getByteString)) #else ed25519GenKeyPair :: IO (Ed25519.PublicKey, Ed25519.PrivateKey) ed25519GenKeyPair = do diff --git a/src/Pact/Types/Server.hs b/src/Pact/Types/Server.hs index 94948c0a3..f1953acb8 100644 --- a/src/Pact/Types/Server.hs +++ b/src/Pact/Types/Server.hs @@ -11,7 +11,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +-- {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Pact.Types.Server diff --git a/tests/pact/verifier-test.repl b/tests/pact/verifier-test.repl index 3065c6ca0..6523a81b8 100644 --- a/tests/pact/verifier-test.repl +++ b/tests/pact/verifier-test.repl @@ -2,7 +2,7 @@ (defcap GOV () true) (defcap GOOD () - (enforce-verifier 'HYPERLANE) + (enforce-verifier 'HYPERLANE) ) (defcap BAD ()