From b8281848da829521c7f4155befea4c89563a3122 Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Tue, 10 Oct 2023 14:57:03 +0200 Subject: [PATCH 1/2] Initial skeleton --- cabal.project | 1 + lib/customer-deposit-wallet/LICENSE | 177 ++++++++++++++++ .../api/http/Cardano/Wallet/Deposit/HTTP.hs | 6 + .../customer-deposit-wallet.cabal | 133 ++++++++++++ .../exe/customer-deposit-wallet.hs | 4 + .../src/Cardano/Wallet/Deposit/IO.hs | 166 +++++++++++++++ .../src/Cardano/Wallet/Deposit/IO/DB.hs | 97 +++++++++ .../Cardano/Wallet/Deposit/IO/Network/Type.hs | 61 ++++++ .../src/Cardano/Wallet/Deposit/Pure.hs | 192 ++++++++++++++++++ .../Cardano/Wallet/Deposit/Pure/Balance.hs | 106 ++++++++++ .../Wallet/Deposit/Pure/Submissions.hs | 72 +++++++ .../src/Cardano/Wallet/Deposit/Pure/UTxO.hs | 13 ++ .../Wallet/Deposit/Pure/UTxOHistory.hs | 9 + .../src/Cardano/Wallet/Deposit/Read.hs | 150 ++++++++++++++ .../src/Cardano/Wallet/Deposit/Write.hs | 43 ++++ .../unit/Cardano/Wallet/Deposit/PureSpec.hs | 65 ++++++ lib/customer-deposit-wallet/test/unit/Spec.hs | 1 + .../test/unit/test-suite-unit.hs | 13 ++ 18 files changed, 1309 insertions(+) create mode 100644 lib/customer-deposit-wallet/LICENSE create mode 100644 lib/customer-deposit-wallet/api/http/Cardano/Wallet/Deposit/HTTP.hs create mode 100644 lib/customer-deposit-wallet/customer-deposit-wallet.cabal create mode 100644 lib/customer-deposit-wallet/exe/customer-deposit-wallet.hs create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxOHistory.hs create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs create mode 100644 lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs create mode 100644 lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs create mode 100644 lib/customer-deposit-wallet/test/unit/Spec.hs create mode 100644 lib/customer-deposit-wallet/test/unit/test-suite-unit.hs diff --git a/cabal.project b/cabal.project index 646b36720c9..4fcc2ce5f95 100644 --- a/cabal.project +++ b/cabal.project @@ -64,6 +64,7 @@ packages: , lib/crypto-hash-extra/ , lib/coin-selection/ , lib/conversions/ + , lib/customer-deposit-wallet/ , lib/delta-store/ , lib/delta-table , lib/delta-types/ diff --git a/lib/customer-deposit-wallet/LICENSE b/lib/customer-deposit-wallet/LICENSE new file mode 100644 index 00000000000..f433b1a53f5 --- /dev/null +++ b/lib/customer-deposit-wallet/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/lib/customer-deposit-wallet/api/http/Cardano/Wallet/Deposit/HTTP.hs b/lib/customer-deposit-wallet/api/http/Cardano/Wallet/Deposit/HTTP.hs new file mode 100644 index 00000000000..85ea812b64d --- /dev/null +++ b/lib/customer-deposit-wallet/api/http/Cardano/Wallet/Deposit/HTTP.hs @@ -0,0 +1,6 @@ +module Cardano.Wallet.Deposit.HTTP + ( Wallet.WalletEnv + ) where + +import qualified Cardano.Wallet.Deposit.IO as Wallet + diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal new file mode 100644 index 00000000000..c7c40f85caf --- /dev/null +++ b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal @@ -0,0 +1,133 @@ +cabal-version: 3.0 +build-type: Simple +name: customer-deposit-wallet +version: 0.1.0.0 +synopsis: A wallet for the Cardano blockchain. +description: Please see README.md +homepage: https://github.com/cardano-foundation/cardano-wallet +license: Apache-2.0 +license-file: LICENSE +author: HAL, Cardano Foundation +maintainer: hal@cardanofoundation.org +copyright: 2023 Cardano Foundation +category: Web + +extra-source-files: + spec/**/*.agda + +common language + default-language: + Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +common opts-lib + ghc-options: + -Wall -Wcompat + -Wredundant-constraints + -Wincomplete-uni-patterns -Wincomplete-record-updates + + if flag(release) + ghc-options: -O2 -Werror + +common opts-exe + import: opts-lib + ghc-options: -threaded -rtsopts + +flag release + description: Enable optimization and `-Werror` + default: False + manual: True + +library + import: language, opts-lib + hs-source-dirs: src + build-depends: + , async + , base + , bech32 + , bytestring + , cardano-addresses + , cardano-wallet + , cardano-wallet-primitive + , cardano-ledger-byron + , containers + , contra-tracer + , deepseq + , delta-store + , delta-types + , directory + , filepath + , io-classes + , iohk-monitoring + , iohk-monitoring-extra ^>=0.1 + , network + , network-mux + , network-uri + , nothunks + , ntp-client + , ouroboros-consensus-cardano + , persistent ^>=2.13 + , persistent-sqlite ^>=2.13 + , persistent-template ^>=2.12 + , retry + , text + , time + , typed-protocols + exposed-modules: + Cardano.Wallet.Deposit.IO + Cardano.Wallet.Deposit.IO.DB + Cardano.Wallet.Deposit.IO.Network.Type + Cardano.Wallet.Deposit.Pure + Cardano.Wallet.Deposit.Pure.Balance + Cardano.Wallet.Deposit.Pure.UTxO + Cardano.Wallet.Deposit.Pure.UTxOHistory + Cardano.Wallet.Deposit.Pure.Submissions + Cardano.Wallet.Deposit.Read + Cardano.Wallet.Deposit.Write + +test-suite unit + import: language, opts-exe + type: exitcode-stdio-1.0 + hs-source-dirs: test/unit + main-is: test-suite-unit.hs + build-depends: + , base + , cardano-wallet + , cardano-wallet-primitive + , cardano-wallet-test-utils + , customer-deposit-wallet + , hspec >=2.8.2 + , QuickCheck + , with-utf8 + build-tool-depends: hspec-discover:hspec-discover + other-modules: + Cardano.Wallet.Deposit.PureSpec + Spec + +library customer-deposit-wallet-http + import: language, opts-lib + hs-source-dirs: api/http + build-depends: + , base + , aeson + , customer-deposit-wallet + , http-api-data + , http-types + , optparse-applicative + , tls + , servant + , servant-server + exposed-modules: + Cardano.Wallet.Deposit.HTTP + +executable customer-deposit-wallet + import: language, opts-exe + hs-source-dirs: exe + build-depends: + , base + , customer-deposit-wallet + , customer-deposit-wallet-http + main-is: + customer-deposit-wallet.hs diff --git a/lib/customer-deposit-wallet/exe/customer-deposit-wallet.hs b/lib/customer-deposit-wallet/exe/customer-deposit-wallet.hs new file mode 100644 index 00000000000..0e8df19982e --- /dev/null +++ b/lib/customer-deposit-wallet/exe/customer-deposit-wallet.hs @@ -0,0 +1,4 @@ +import Prelude + +main :: IO () +main = pure () diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs new file mode 100644 index 00000000000..ebf8441a7a4 --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecordWildCards #-} +module Cardano.Wallet.Deposit.IO + ( + -- * Types + WalletEnv + , WalletInstance + + -- * Operations + -- ** Initialization + , withWallet + + -- ** Mapping between customers and addresses + , listCustomers + , createAddress + + -- ** Reading from the blockchain + , availableBalance + , getCustomerHistory + + -- ** Writing to the blockchain + , createPayment + ) where + +import Prelude + +import Cardano.Wallet.Deposit.Pure + ( Customer, WalletState ) +import Cardano.Wallet.Deposit.Read + ( Address ) +import Control.Tracer + ( Tracer, contramap ) +import Data.Bifunctor + ( first ) +import Data.List.NonEmpty + ( NonEmpty ) + +import qualified Cardano.Wallet.Deposit.IO.DB as DB +import qualified Cardano.Wallet.Deposit.IO.Network.Type as Network +import qualified Cardano.Wallet.Deposit.Pure as Wallet +import qualified Cardano.Wallet.Deposit.Read as Read +import qualified Cardano.Wallet.Deposit.Write as Write +import qualified Control.Concurrent.Async as Async +import qualified Data.DBVar as DBVar +import qualified Data.Delta as Delta + ( Replace (..) ) +import qualified Data.Delta.Update as Delta +import qualified Data.Store as Store + +{----------------------------------------------------------------------------- + Types +------------------------------------------------------------------------------} +data WalletEnv m = + WalletEnv + { logger :: Tracer m WalletLog + , genesisData :: Read.GenesisData + , networkEnv :: Network.NetworkEnv m Read.Block + , database :: Store.UpdateStore DB.SqlM Wallet.DeltaWalletState + , atomically :: forall a. DB.SqlM a -> m a + } + +data WalletInstance = WalletInstance + { env :: WalletEnv IO + , walletState :: DBVar.DBVar DB.SqlM Wallet.DeltaWalletState + } + +{----------------------------------------------------------------------------- + Helpers +------------------------------------------------------------------------------} +-- | Convenience to apply an 'Update' to the 'WalletState' via the 'DBLayer'. +onWalletState + :: WalletInstance + -> Delta.Update Wallet.DeltaWalletState r + -> IO r +onWalletState WalletInstance{env,walletState} update' = + atomically env $ Delta.onDBVar walletState update' + +-- | Convenience to read the 'WalletState'. +-- +-- Use 'onWalletState' if you want to use the result in an atomic update. +readWalletState :: WalletInstance -> IO WalletState +readWalletState WalletInstance{env,walletState} = + atomically env $ DBVar.readDBVar walletState + +{----------------------------------------------------------------------------- + Operations + Initialization +------------------------------------------------------------------------------} +withWallet :: WalletEnv IO -> (WalletInstance -> IO a) -> IO a +withWallet env@WalletEnv{..} action = do + walletState <- loadWalletStateFromDatabase + let w = WalletInstance{env,walletState} + Async.withAsync (doChainSync w) $ \_ -> action w + where + loadWalletStateFromDatabase = atomically $ do + es <- Store.loadS database + case es of + Left _ -> + DBVar.initDBVar database $ Wallet.fromGenesis genesisData + Right _ -> + DBVar.loadDBVar database + + doChainSync = Network.chainSync networkEnv trChainSync . chainFollower + trChainSync = contramap (\_ -> WalletLogDummy) logger + chainFollower w = Network.ChainFollower + { checkpointPolicy = undefined + , readChainPoints = undefined + , rollForward = rollForward w + , rollBackward = rollBackward w + } + +{----------------------------------------------------------------------------- + Operations +------------------------------------------------------------------------------} +listCustomers :: WalletInstance -> IO [(Customer, Address)] +listCustomers w = + Wallet.listCustomers <$> readWalletState w + +createAddress :: Customer -> WalletInstance -> IO Address +createAddress c w = + onWalletState w + $ Delta.updateWithResult + $ \s0 -> + let (r,s1) = Wallet.createAddress c s0 + in (Delta.Replace s1, r) + +{----------------------------------------------------------------------------- + Operations + Reading from the blockchain +------------------------------------------------------------------------------} +availableBalance :: WalletInstance -> IO Read.Value +availableBalance w = + Wallet.availableBalance <$> readWalletState w + +getCustomerHistory :: WalletInstance -> Customer -> IO [Wallet.TxSummary] +getCustomerHistory w c = + Wallet.getCustomerHistory c <$> readWalletState w + +rollForward :: WalletInstance -> NonEmpty Read.Block -> tip -> IO () +rollForward w blocks _nodeTip = + onWalletState w + $ Delta.update + $ Delta.Replace . Wallet.rollForwardMany blocks + +rollBackward :: WalletInstance -> Read.ChainPoint -> IO Read.ChainPoint +rollBackward w point = + onWalletState w + $ Delta.updateWithResult + $ first Delta.Replace . Wallet.rollBackward point + +{----------------------------------------------------------------------------- + Operations + Writing to blockchain +------------------------------------------------------------------------------} + +createPayment + :: WalletInstance -> [(Address, Read.Value)] -> IO (Maybe Write.Tx) +createPayment w destinations = + Wallet.createPayment destinations <$> readWalletState w + +{----------------------------------------------------------------------------- + Logging +------------------------------------------------------------------------------} +data WalletLog + = WalletLogDummy diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs new file mode 100644 index 00000000000..b3d34284068 --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Rank2Types #-} +module Cardano.Wallet.Deposit.IO.DB + ( SqlM + , SqlContext (..) + , withSqliteFile + + , DBLog (..) + ) where + +import Prelude + +import Cardano.BM.Extra + ( bracketTracer ) +import Cardano.DB.Sqlite + ( DBLog (..), dbBackend, withDBHandle ) +import Control.Concurrent.MVar + ( newMVar, withMVar ) +import Control.Tracer + ( Tracer, contramap ) +import Data.Time.Clock + ( NominalDiffTime ) + +import qualified Database.Persist.Sql as Persistent + +{----------------------------------------------------------------------------- + Comment layout +------------------------------------------------------------------------------} +-- | Monad to run SQL queries in. +type SqlM = Persistent.SqlPersistT IO + +-- | A facility to run 'SqlM' computations. +-- Importantly, computations are not run in parallel, but sequenced. +newtype SqlContext = SqlContext + { runQuery :: forall a. SqlM a -> IO a + } + +-- | Open an .sqlite database file +-- and provide an 'SqlContext' for running 'SqlM' actions. +withSqliteFile + :: Tracer IO DBLog + -- ^ Logging + -> FilePath + -- ^ Database file + -> (SqlContext -> IO a) + -- ^ Action to run + -> IO a +withSqliteFile tr fp action = do + -- Lock ensures that database operations are sequenced. + lock <- newMVar () + withDBHandle tr fp $ \dbHandle -> + let + -- Run a query on the open database, + -- but retry on busy. + runQuery :: SqlM a -> IO a + runQuery cmd = + observe + . retryOnBusy tr retryOnBusyTimeout + $ withMVar lock + $ const + $ Persistent.runSqlConn cmd + $ dbBackend dbHandle + in + action $ SqlContext{runQuery} + where + observe :: IO a -> IO a + observe = bracketTracer (contramap MsgRun tr) + +-- | Retry an action if the database yields an 'SQLITE_BUSY' error. +-- +-- From +-- +-- The SQLITE_BUSY result code indicates that the database file could not be +-- written (or in some cases read) because of concurrent activity by some +-- other database connection, usually a database connection in a separate +-- process. +-- +-- For example, if process A is in the middle of a large write transaction +-- and at the same time process B attempts to start a new write transaction, +-- process B will get back an SQLITE_BUSY result because SQLite only supports +-- one writer at a time. Process B will need to wait for process A to finish +-- its transaction before starting a new transaction. The sqlite3_busy_timeout() +-- and sqlite3_busy_handler() interfaces and the busy_timeout pragma are +-- available to process B to help it deal with SQLITE_BUSY errors. +retryOnBusy + :: Tracer IO DBLog + -- ^ Logging + -> NominalDiffTime + -- ^ Timeout + -> IO a + -- ^ Action to retry + -> IO a +retryOnBusy _ _ action = action -- FIXME + +-- | Default timeout for `retryOnBusy` +retryOnBusyTimeout :: NominalDiffTime +retryOnBusyTimeout = 60 diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs new file mode 100644 index 00000000000..3171dedd6b3 --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveGeneric #-} +module Cardano.Wallet.Deposit.IO.Network.Type + ( NetworkEnv (..) + , ChainFollower (..) + ) where + +import Prelude + +import Cardano.Wallet.Network + ( ChainFollower (..) ) +import Control.Tracer + ( Tracer ) +import Data.List.NonEmpty + ( NonEmpty ) +import Data.Text + ( Text ) +import Data.Void + ( Void ) +import GHC.Generics + ( Generic ) + +import qualified Cardano.Wallet.Deposit.Read as Read + +{----------------------------------------------------------------------------- + Type +------------------------------------------------------------------------------} + +data NetworkEnv m block = NetworkEnv + { chainSync + :: Tracer m ChainFollowLog + -> ChainFollower m Read.ChainPoint Read.ChainPoint (NonEmpty block) + -> m Void + -- ^ Run the chain-sync mini-protocol (forever). + + , postTx + :: Read.Tx -> m (Either ErrPostTx ()) + -- ^ Post a transaction to the Cardano network. + + } + +{------------------------------------------------------------------------------- + Errors +-------------------------------------------------------------------------------} + +-- | Error while trying to send a transaction to the network. +data ErrPostTx + = ErrPostTxValidationError Text + | ErrPostTxMempoolFull + deriving (Eq, Show, Generic) + +{------------------------------------------------------------------------------- + Logging +-------------------------------------------------------------------------------} + +-- | Higher level log of a chain follower. +-- -- Includes computed statistics about synchronization progress. +data ChainFollowLog + -- = MsgChainSync (ChainSyncLog BlockHeader ChainPoint) + -- | MsgFollowStats (FollowStats Rearview) + = MsgStartFollowing + deriving (Eq, Show, Generic) diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs new file mode 100644 index 00000000000..f1cfee048c0 --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs @@ -0,0 +1,192 @@ +module Cardano.Wallet.Deposit.Pure + ( + -- * Types + WalletState + , DeltaWalletState + + -- * Operations + -- ** Mapping between customers and addresses + , Customer + , listCustomers + , createAddress + , deriveAddress + , knownCustomer + , knownCustomerAddress + , isCustomerAddress + + -- ** Reading from the blockchain + , fromGenesis + , localTip + , availableBalance + , rollForwardMany + , rollForwardOne + , rollBackward + + , TxSummary (..) + , ValueTransfer (..) + , getCustomerHistory + + -- ** Writing to the blockchain + , createPayment + + , addTxSubmission + , listTxsInSubmission + + -- * Internal + , fromGenesisUTxO + ) where + +import Prelude + +import Cardano.Wallet.Deposit.Pure.UTxOHistory + ( UTxOHistory ) +import Cardano.Wallet.Deposit.Read + ( Address ) +import Data.Foldable + ( foldl' ) +import Data.List.NonEmpty + ( NonEmpty ) +import Data.Maybe + ( isJust ) +import Data.Set + ( Set ) +import Numeric.Natural + ( Natural ) + +import qualified Cardano.Wallet.Deposit.Pure.Balance as Balance +import qualified Cardano.Wallet.Deposit.Pure.Submissions as Sbm +import qualified Cardano.Wallet.Deposit.Pure.UTxO as UTxO +import qualified Cardano.Wallet.Deposit.Pure.UTxOHistory as UTxOHistory +import qualified Cardano.Wallet.Deposit.Read as Read +import qualified Cardano.Wallet.Deposit.Write as Write +import qualified Data.Delta as Delta +import qualified Data.Map.Strict as Map + +{----------------------------------------------------------------------------- + Types +------------------------------------------------------------------------------} +type Customer = Natural + +data WalletState = WalletState + { customers :: !(Map.Map Customer Address) + , changeAddress :: !Address + , utxoHistory :: !UTxOHistory.UTxOHistory + -- , txHistory :: [Read.Tx] + , submissions :: Sbm.TxSubmissions + -- , credentials :: Maybe (HashedCredentials (KeyOf s)) + -- , info :: !WalletInfo + } + deriving (Eq, Show) + +type DeltaWalletState = Delta.Replace WalletState + +{----------------------------------------------------------------------------- + Operations + Mapping between customers and addresses +------------------------------------------------------------------------------} + +listCustomers :: WalletState -> [(Customer, Address)] +listCustomers = Map.toList . customers + +createAddress :: Customer -> WalletState -> (Address, WalletState) +createAddress = undefined + +-- depend on the private key only, not on the entire wallet state +deriveAddress :: WalletState -> (Customer -> Address) +deriveAddress = undefined + +knownCustomer :: Customer -> WalletState -> Bool +knownCustomer c = (c `Map.member`) . customers + +knownCustomerAddress :: Address -> WalletState -> Bool +knownCustomerAddress address = isJust . isCustomerAddress address + +isCustomerAddress :: Address -> WalletState -> Maybe Customer +isCustomerAddress _ _ = Nothing + +{----------------------------------------------------------------------------- + Operations + Reading from the blockchain +------------------------------------------------------------------------------} + +fromGenesis :: Read.GenesisData -> WalletState +fromGenesis = undefined + +fromGenesisUTxO :: Read.UTxO -> WalletState +fromGenesisUTxO utxo = + WalletState + { customers = Map.empty + , changeAddress = Read.dummyAddress + , utxoHistory = UTxOHistory.empty utxo + , submissions = Sbm.empty + } + +localTip :: WalletState -> Read.ChainPoint +localTip = error "localTip" + +rollForwardMany :: NonEmpty Read.Block -> WalletState -> WalletState +rollForwardMany blocks w = foldl' (flip rollForwardOne) w blocks + +rollForwardOne :: Read.Block -> WalletState -> WalletState +rollForwardOne block w = + w + { utxoHistory = rollForwardUTxO isOurs block (utxoHistory w) + , submissions = Delta.apply (Sbm.rollForward block) (submissions w) + } + where + isOurs :: Address -> Bool + isOurs addr = + ( addr == changeAddress w ) || knownCustomerAddress addr w + -- FIXME: Consider payment part only, ignore staking part. + +rollForwardUTxO + :: (Address -> Bool) -> Read.Block -> UTxOHistory -> UTxOHistory +rollForwardUTxO isOurs block u = + Delta.apply (UTxOHistory.AppendBlock slot deltaUTxO) u + where + (deltaUTxO,_) = Balance.applyBlock isOurs block (UTxOHistory.getUTxO u) + slot = Read.slot . Read.blockHeaderBody $ Read.blockHeader block + +rollBackward + :: Read.ChainPoint + -> WalletState + -> (WalletState, Read.ChainPoint) +rollBackward = undefined + +availableBalance :: WalletState -> Read.Value +availableBalance w = + UTxO.balance $ Balance.availableUTxO utxo pending + where + pending = listTxsInSubmission w + utxo = UTxOHistory.getUTxO $ utxoHistory w + +data TxSummary = TxSummary + { txid :: Read.TxId + , blockHeaderBody :: Read.BHBody + , transfer :: ValueTransfer + } + +data ValueTransfer = ValueTransfer + { spent :: Read.Value + , received :: Read.Value + } + +getCustomerHistory :: Customer -> WalletState -> [TxSummary] +getCustomerHistory = undefined + +{----------------------------------------------------------------------------- + Operations + Writing to blockchain +------------------------------------------------------------------------------} + +createPayment :: [(Address, Write.Value)] -> WalletState -> Maybe Write.Tx +createPayment = undefined + -- needs balanceTx + -- needs to sign the transaction + +addTxSubmission :: Write.Tx -> WalletState -> WalletState +addTxSubmission _tx _w = undefined + +listTxsInSubmission :: WalletState -> Set Write.Tx +-- listTxsInSubmission = Sbm.listInSubmission . submissions +listTxsInSubmission _ = mempty diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs new file mode 100644 index 00000000000..1b55dfa5afe --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE BangPatterns #-} +-- | Wallet balance. +module Cardano.Wallet.Deposit.Pure.Balance + ( balance + , availableUTxO + , applyBlock + ) where + +import Prelude + +import Cardano.Wallet.Deposit.Pure.UTxO + ( DeltaUTxO, UTxO, balance, excluding ) +import Cardano.Wallet.Primitive.Model + ( utxoFromTx ) +import Data.Foldable + ( foldMap' ) +import Data.Set + ( Set ) + +import qualified Cardano.Wallet.Deposit.Pure.UTxO as UTxO +import qualified Cardano.Wallet.Deposit.Read as Read +import qualified Cardano.Wallet.Deposit.Write as Write +import qualified Data.Set as Set + +{----------------------------------------------------------------------------- + Wallet Balance +------------------------------------------------------------------------------} +-- | Available = excluding pending transactions +availableUTxO :: UTxO -> Set Write.Tx -> UTxO +availableUTxO u pending = + u `excluding` used + where + used :: Set Read.TxIn + used = foldMap' getUsedTxIn pending + + -- UTxO which have been spent or committed as collateral in a pending + -- transaction are not available to use in future transactions. + getUsedTxIn :: Write.Tx -> Set Read.TxIn + getUsedTxIn tx = + Write.spendInputs (Write.txbody tx) + <> Write.collInputs (Write.txbody tx) + +{----------------------------------------------------------------------------- + Applying Blocks +------------------------------------------------------------------------------} +type IsOurs addr = addr -> Bool + +-- | Apply a 'Block' to the 'UTxO'. +-- +-- Returns both a delta and the new value. +applyBlock + :: IsOurs Read.Addr -> Read.Block -> UTxO -> (DeltaUTxO, UTxO) +applyBlock isOurs block u0 = + (mconcat $ reverse dus, u1) + where + (dus, u1) = mapAccumL' (applyTx isOurs) u0 $ Read.transactions block + +-- | Apply a transactions to the 'UTxO'. +-- +-- Returns both a delta and the new value. +applyTx + :: IsOurs Read.Addr -> Read.Tx -> UTxO -> (DeltaUTxO, UTxO) +applyTx isOurs tx u0 = + if isUnchangedUTxO + then (mempty, u0) + else (du, u) + where + (du, u) = (du21 <> du10, u2) + + (du10, u1) = spendTxD tx u0 + receivedUTxO = UTxO.filterByAddress isOurs (utxoFromTx tx) + (du21, u2) = UTxO.receiveD u1 receivedUTxO + + -- NOTE: Performance. + -- 'applyTx' is part of a tight loop that inspects all transactions + -- (> 30M Txs as of Feb 2022). + -- Thus, we make a small performance optimization here. + -- Specifically, we want to reject a transaction as soon as possible + -- if it does not change the 'UTxO' set. The test + isUnchangedUTxO = UTxO.null receivedUTxO && mempty == du10 + -- allocates slightly fewer new Set/Map than the definition + -- isUnchangedUTxO = mempty == du + +{----------------------------------------------------------------------------- + UTxO utilities +------------------------------------------------------------------------------} +-- | Remove unspent outputs that are consumed by the given transaction. +spendTxD :: Read.Tx -> UTxO -> (DeltaUTxO, UTxO) +spendTxD tx !u = + u `UTxO.excludingD` Set.fromList inputsToExclude + where + inputsToExclude = + if Read.txScriptInvalid tx + then Read.collateralInputs tx + else Read.inputs tx + +{----------------------------------------------------------------------------- + Helpers +------------------------------------------------------------------------------} +-- | Strict variant of 'mapAccumL'. +mapAccumL' :: (a -> s -> (o,s)) -> s -> [a] -> ([o],s) +mapAccumL' f = go [] + where + go os !s0 [] = (reverse os, s0) + go os !s0 (x:xs) = case f x s0 of + (!o,!s1) -> go (o:os) s1 xs diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs new file mode 100644 index 00000000000..3e3e3d9d1fe --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Cardano.Wallet.Deposit.Pure.Submissions + ( TxSubmissions + , TxSubmissionsStatus + , DeltaTxSubmissions1 + , DeltaTxSubmissions + + , empty + , add + , listInSubmission + , rollForward + , rollBackward + ) where + +import Prelude + +import Data.Set + ( Set ) + +import qualified Cardano.Wallet.Deposit.Read as Read +import qualified Cardano.Wallet.Submissions.Operations as Sbm +import qualified Cardano.Wallet.Submissions.Submissions as Sbm +import qualified Cardano.Wallet.Submissions.TxStatus as Sbm +import qualified Data.Delta as Delta + +{----------------------------------------------------------------------------- + Types +------------------------------------------------------------------------------} +type TxSubmissions + = Sbm.Submissions () Read.Slot (Read.TxId, Read.Tx) +type TxSubmissionsStatus + = Sbm.TxStatusMeta () Read.Slot (Read.TxId, Read.Tx) +type DeltaTxSubmissions1 + = Sbm.Operation () Read.Slot (Read.TxId, Read.Tx) +type DeltaTxSubmissions + = [DeltaTxSubmissions1] + +instance Delta.Delta DeltaTxSubmissions1 where + type Base DeltaTxSubmissions1 = TxSubmissions + apply = Sbm.applyOperations + +instance Sbm.HasTxId (Read.TxId, Read.Tx) where + type TxId (Read.TxId, Read.Tx) = Read.TxId + txId = fst + +{----------------------------------------------------------------------------- + Operations +------------------------------------------------------------------------------} + +empty :: TxSubmissions +empty = Sbm.mkEmpty 0 + +-- | Add a /new/ transaction to the local submission pool +-- with the most recent submission slot. +add :: Read.Tx -> Read.Slot -> DeltaTxSubmissions +add = undefined + +listInSubmission :: TxSubmissions -> Set Read.Tx +listInSubmission = undefined + +rollForward :: Read.Block -> DeltaTxSubmissions +rollForward block = [ Sbm.RollForward tip txs ] + where + tip = undefined block + txids = undefined block + txs = map (tip,) txids + +rollBackward :: Read.Slot -> DeltaTxSubmissions +rollBackward = undefined diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs new file mode 100644 index 00000000000..ef13ce0b383 --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs @@ -0,0 +1,13 @@ +module Cardano.Wallet.Deposit.Pure.UTxO + ( UTxO + , balance + , excluding + , filterByAddress + + , DeltaUTxO + , excludingD + , receiveD + , null + ) where + +import Cardano.Wallet.Primitive.Types.UTxO diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxOHistory.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxOHistory.hs new file mode 100644 index 00000000000..9df44a4994e --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxOHistory.hs @@ -0,0 +1,9 @@ +module Cardano.Wallet.Deposit.Pure.UTxOHistory + ( UTxOHistory + , empty + + , DeltaUTxOHistory (..) + , getUTxO + ) where + +import Cardano.Wallet.DB.Store.UTxOHistory.Model diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs new file mode 100644 index 00000000000..b6da260553c --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs @@ -0,0 +1,150 @@ +-- | Indirection module that re-exports types +-- used for reading data from the blockchain, +-- from all eras. +-- +-- TODO: Match this up with the @Read@ hierarchy. +module Cardano.Wallet.Deposit.Read + ( Network (..) + , Slot + , ChainPoint (..) + + , Addr + , Address + + , Ix + , TxIn + , TxOut + , Value + , UTxO + + , TxId + , Tx + , W.txScriptInvalid + , W.collateralInputs + , W.inputs + , W.outputs + , W.collateralOutput + + , TxBody + , TxWitness + + , BlockNo + , Block (..) + , BHeader (..) + , BHBody (..) + + , GenesisData + , GenesisHash + + -- * Dummy Values useful for testing + , dummyAddress + , dummyBHeader + ) where + +import Prelude + +import Data.ByteString + ( ByteString ) +import Numeric.Natural + ( Natural ) + +import qualified Cardano.Chain.Genesis as Byron +import qualified Cardano.Wallet.Primitive.Types as W +import qualified Cardano.Wallet.Primitive.Types.Address as W +import qualified Cardano.Wallet.Primitive.Types.TokenBundle as W +import qualified Cardano.Wallet.Primitive.Types.Tx as W +import qualified Cardano.Wallet.Primitive.Types.Tx.TxIn as W +import qualified Cardano.Wallet.Primitive.Types.Tx.TxOut as W +import qualified Cardano.Wallet.Primitive.Types.UTxO as W +import qualified Data.ByteString as BS +-- import qualified Ouroboros.Consensus.Cardano.Block as O + +{----------------------------------------------------------------------------- + Type definitions + with dummies +------------------------------------------------------------------------------} +data Network = Testnet | Mainnet + +-- Spec: type Slot = Natural +type Slot = W.SlotNo + +data ChainPoint = Origin | At Slot + +-- newtype Addr = Addr { getAddressBytes :: ByteString } +-- deriving (Eq, Show) +type Addr = W.Address + +-- | Synonym for readability. +-- The ledger specifications define @Addr@. +-- Byron addresses are represented by @Addr_bootstrap@. +type Address = Addr + +dummyAddress :: Address +dummyAddress = W.Address . BS.pack $ replicate 32 0 + +type Ix = Natural + +-- type TxIn = (TxId, Ix) +type TxIn = W.TxIn + +-- type TxOut = (Addr, Value) +type TxOut = W.TxOut + +type Value = W.TokenBundle + +-- type UTxO = Map TxIn TxOut +type UTxO = W.UTxO + +type TxId = ByteString + +type Tx = W.Tx + +type TxBody = () + +type TxWitness = () + +type BlockNo = Natural + +-- type Block = O.CardanoBlock O.StandardCrypto +data Block = Block + { blockHeader :: BHeader + , transactions :: [Tx] + } + deriving (Eq, Ord, Show) + +data BHeader = BHeader + { blockHeaderBody :: BHBody + , blockHeaderSignature :: Sig + } + deriving (Eq, Ord, Show) + +dummyBHeader :: BHeader +dummyBHeader = BHeader + { blockHeaderBody = dummyBHBody + , blockHeaderSignature = () + } + +type Sig = () + +data BHBody = BHBody + { prev :: Maybe HashHeader + , blockno :: BlockNo + , slot :: Slot + , bhash :: HashBBody + } + deriving (Eq, Ord, Show) + +type HashHeader = () +type HashBBody = () + +dummyBHBody :: BHBody +dummyBHBody = BHBody + { prev = Nothing + , blockno = 128 + , slot = 42 + , bhash = () + } + +-- GenesisData is not part of the ledger specification proper +type GenesisData = Byron.GenesisData +type GenesisHash = Byron.GenesisHash diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs new file mode 100644 index 00000000000..3c394c362ed --- /dev/null +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs @@ -0,0 +1,43 @@ +-- | Indirection module that re-exports types +-- used for writing transactions to the blockchain, +-- in the most recent and the next future eras. +-- +-- TODO: Match this up with the @Write@ hierarchy. +module Cardano.Wallet.Deposit.Write + ( Address + + , Value + + , TxId + , Tx (..) + , TxBody (..) + , TxWitness + ) where + +import Prelude + +import Data.Map + ( Map ) +import Data.Set + ( Set ) + +import Cardano.Wallet.Deposit.Read hiding + ( Tx, TxBody ) + +{----------------------------------------------------------------------------- + Type definitions + with dummies +------------------------------------------------------------------------------} +data Tx = Tx + { txbody :: TxBody + , txwits :: TxWitness + } + deriving (Eq, Ord, Show) + +data TxBody = TxBody + { spendInputs :: Set TxIn + , collInputs :: Set TxIn + , txouts :: Map Ix TxOut + , collRet :: Maybe TxOut + } + deriving (Eq, Ord, Show) diff --git a/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs new file mode 100644 index 00000000000..d1a6b5fe98d --- /dev/null +++ b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs @@ -0,0 +1,65 @@ +module Cardano.Wallet.Deposit.PureSpec + ( spec + ) where + +import Prelude + +import Cardano.Wallet.Primitive.Types.Tx.TxSeq + ( toTxList ) +import Cardano.Wallet.Primitive.Types.Tx.TxSeq.Gen + ( genTxSeq, getTxSeq ) +import Cardano.Wallet.Primitive.Types.UTxO.Gen + ( genUTxO ) +import Data.Maybe + ( isJust ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Gen, Property, cover, forAll, property, suchThat ) + +import qualified Cardano.Wallet.Deposit.Pure as Wallet +import qualified Cardano.Wallet.Deposit.Read as Read + +spec :: Spec +spec = do + describe "rollForwardOne" $ + it "adds initial UTxO" + prop_rollForwardOne_UTxO + +{----------------------------------------------------------------------------- + Properties +------------------------------------------------------------------------------} +prop_rollForwardOne_UTxO + :: Property +prop_rollForwardOne_UTxO = + forAll genBlock $ \block -> + -- The wallet has a nonzero balance most of the time + -- FIXME: Should have all the time? + cover 50 (hasFunds $ Wallet.rollForwardOne block w0) + "has balance" (property True) + where + w0 = Wallet.fromGenesisUTxO mempty + hasFunds w1 = mempty /= Wallet.availableBalance w1 + +hasOutputs :: Read.Tx -> Bool +hasOutputs tx = + if Read.txScriptInvalid tx + then isJust $ Read.collateralOutput tx + else not . null $ Read.outputs tx + +haveSomeOutputs :: Read.Block -> Bool +haveSomeOutputs = any hasOutputs . Read.transactions + +genBlock :: Gen Read.Block +genBlock = + (mkBlock <$> genTxs) `suchThat` haveSomeOutputs + where + genTxs = toTxList . getTxSeq <$> genTxSeq genUTxO genAddress + mkBlock transactions = + Read.Block + { Read.blockHeader = Read.dummyBHeader + , Read.transactions = transactions + } + +genAddress :: Gen Read.Address +genAddress = pure Read.dummyAddress diff --git a/lib/customer-deposit-wallet/test/unit/Spec.hs b/lib/customer-deposit-wallet/test/unit/Spec.hs new file mode 100644 index 00000000000..5416ef6a866 --- /dev/null +++ b/lib/customer-deposit-wallet/test/unit/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/lib/customer-deposit-wallet/test/unit/test-suite-unit.hs b/lib/customer-deposit-wallet/test/unit/test-suite-unit.hs new file mode 100644 index 00000000000..349e4b80090 --- /dev/null +++ b/lib/customer-deposit-wallet/test/unit/test-suite-unit.hs @@ -0,0 +1,13 @@ +module Main where + +import Prelude + +import Main.Utf8 + ( withUtf8 ) +import Test.Hspec.Extra + ( hspecMain ) + +import qualified Spec + +main :: IO () +main = withUtf8 $ hspecMain Spec.spec From ea3fb39af81d824b360e1bece6e977a792485ceb Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Thu, 12 Oct 2023 17:33:05 +0200 Subject: [PATCH 2/2] Initial specification as literate Agda file --- .../spec/customer-deposit-wallet.lagda.md | 418 ++++++++++++++++++ 1 file changed, 418 insertions(+) create mode 100644 lib/customer-deposit-wallet/spec/customer-deposit-wallet.lagda.md diff --git a/lib/customer-deposit-wallet/spec/customer-deposit-wallet.lagda.md b/lib/customer-deposit-wallet/spec/customer-deposit-wallet.lagda.md new file mode 100644 index 00000000000..f2c62a03439 --- /dev/null +++ b/lib/customer-deposit-wallet/spec/customer-deposit-wallet.lagda.md @@ -0,0 +1,418 @@ +# Specification: Customer Deposit Wallet + +## Synopsis + +🚧 DRAFT 2023-10-18 + +This document specifies the core functionality of a **customer deposit wallet**, +or **deposit wallet** for short. + +A customer deposit wallet allows you to track the origin of incoming funds: +Each customer is assigned a unique address belonging to the wallet; +a deposit made at this address is treated as originating from the customer. + +Technically, each customer is represented by a numerical index (natural number). +Essentially, the deposit wallet manages a mapping between indices and addresses, +and tracks incoming funds for each known address. + +# Setup + +This document is a [literate Agda][lagda] file: It contains prose that +describes and explains the specification, but it also contains definitions +and logical properties that can be checked by the proof assistant [Agda][]. + +We use Agda because we plan to create a **machine-checked proof** +that our implementation adheres to this specification. +Specifically, we plan to implement the core functionality in Agda, +i.e. the functionality specificied in this document, and export +the code to Haskell using [agda2hs][] so that the core functionality +can be embedded in a full software application. + + [agda]: https://github.com/agda/agda + [lagda]: https://agda.readthedocs.io/en/v2.6.4/tools/literate-programming.html + [agda2hs]: https://github.com/agda/agda2hs + +## Imports + +In order to formulate the specification, we need to import standard vocabulary: + +```agda +open import Haskell.Prelude +open import Relation.Nullary using (¬_) +open import Data.Product using () renaming (_×_ to both) +``` + +We also define a few conveniences: + +A predicate `_∈_` that records whether an item is an element of a list + +```agda +_∈_ : ∀ {a : Set} {{_ : Eq a}} → a → List a → Set +x ∈ xs = elem x xs ≡ True +``` + +The logical combinator "if and only if" + +```agda +_⟷_ : Set → Set → Set +x ⟷ y = both (x → y) (y → x) +``` + +```agda +isJust : ∀ {a : Set} → Maybe a → Bool +isJust (Just _) = True +isJust Nothing = False +``` + +```agda +isSubsetOf : ∀ {a : Set} {{_ : Eq a}} → List a → List a → Bool +isSubsetOf xs ys = all (λ x → elem x ys) xs +``` + +# Specification + +## Overview + +This specification of a **customer deposit wallet** +amounts to the specification of an abstract data type `WalletState`, +which represents the entire state of such a wallet. + +The goal of this document is to specify the operations +on this abstract data type and the logical properties that relate them. + +We define a `module` `DepositWallet` which is parametrized by +several definitions from the Cardano ledger, +but also by the abstract data type `WalletState` that we wish to specify. + +```agda +module + DepositWallet + (WalletState : Set) + (Address : Set) + {{_ : Eq Address}} + (Slot : Set) + (TxId : Set) + (Tx : Set) + (Value : Set) + {{_ : Eq Value}} + (PParams : Set) + where +``` + +## Operations + +We now list all auxiliary data types and all +operations supported by the abstract data type `WalletState`. +This list is meant for reference +— we will explain each of them in detail in the subsequent sections. + +Auxiliary data types: + +```agda + Customer = Nat + + record ValueTransfer : Set where + field + spent : Value + received : Value + + open ValueTransfer + + TxSummary : Set + TxSummary = Slot × TxId × ValueTransfer +``` + +Operations: + +```agda + record Operations : Set where + field + + listCustomers : WalletState → List (Customer × Address) + createAddress : Customer → WalletState → (Address × WalletState) + + availableBalance : WalletState → Value + applyTx : Tx → WalletState → WalletState + + getCustomerHistory : WalletState → Customer → List TxSummary + + createPayment + : List (Address × Value) + → PParams → WalletState → Maybe Tx +``` + +## Properties + +In subsequent sections, we will specify the properties that +the operations should satisfy. + +The following record collects the properties: + +```agda + record Properties + (O : Operations) + : Set₁ + where + open Operations O +``` + +(For some reason, it needs to be in `Set₁`.) + +### Mapping between Customers and Address + +The type `Customer` denotes a unique identier for a customer. +For reasons explained later, we choose to represent this type +as numerical indices, i.e. natural numbers: + + Customer = Nat + +The mapping between customers and addresses will be queried and established with +the following operations: + + listCustomers : WalletState → List (Customer × Address) + createAddress : Customer → WalletState → (Address × WalletState) + +Here, `listCustomers` lists all customer/address pairs that have been mapped to each other so far. +In turn, `createAddress` adds a new customer/address to the mapping. + +In order to express how these functions are related, we define + +```agda + knownCustomer : Customer → WalletState → Bool + knownCustomer c = elem c ∘ map fst ∘ listCustomers + + knownCustomerAddress : Address → WalletState → Bool + knownCustomerAddress address = elem address ∘ map snd ∘ listCustomers +``` + +Here, a `knownCustomer` is a `Customer` that appears in the result of `listCustomers`, +while `knownCustomerAddress` is an `Address` that appears in the result. +Note that a deposit wallet may own additional `Addresses` not included here, +such as change addresses — but these addresses are not customer addresses. + +The two operations are related by the property + +```agda + field + + prop_create-get + : ∀(c : Customer) (s0 : WalletState) + → let (address , s1) = createAddress c s0 + in knownCustomerAddress address s1 ≡ True +``` + +### Address derivation + +For compatibility with hardware wallets and the [BIP-32][] standard, +we derive the `Address` of each customer from the root private key +of the wallet in a deterministic fashion: + +```agda + deriveAddress : WalletState → (Customer → Address) + + prop_create-derive + : ∀(c : Customer) (s0 : WalletState) + → let (address , _) = createAddress c s0 + in deriveAddress s0 c ≡ address +``` + +Specifically, in the notation of [BIP-32][], we use + + deriveAddress : WalletState → Nat → Address + deriveAddress s ix = rootXPrv s / 1857' / 1815' / 0' / 0 / ix + +Here, `1857` is a new “purpose” identifier; we cannot reuse the [CIP-1852][] standard, because it behaves differently when discovering funds in blocks. + + [bip-32]: https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki + [cip-1852]: https://cips.cardano.org/cips/cip1852/ + +This method of deriving addresses is also the reason why we choose +a concrete representation of `Customer` as a natural number. + +### Applying transactions + +TODO: Specification of total wallet funds. +Amounts to rewrite of the original wallet specification +by Edsko and Duncan in Agda. To be specified in a separate document. + + availableBalance : WalletState → Value + applyTx : Tx → WalletState → WalletState + +### Tracking incoming funds + +Beyond assigning an address to a customer, +the new wallet state returned by `createAddress` +also tracks this address whenever new blocks are incorporated into the wallet state. +For this purpose of tracking, we introduce an operation + + getCustomerHistory : WalletState → Customer → List TxSummary + +which returns a list of transaction summaries. For a given transaction, such a summary reports the total `Value` spend or received at a specific address. + + record ValueTransfer : Set where + field + spent : Value + received : Value + + open ValueTransfer + + TxSummary : Set + TxSummary = Slot × TxId × ValueTransfer + +Note that `Value` includes both native coins (ADA) and +user-defined assets, such as stablecoins NFTs. +Also note that the customer deposit wallet does not support +delegation and reward accounts, and the `spent` value +can only be spent from transaction outputs. + +The function `getCustomerHistory` allows users to detect incoming +transfers by observing the `received` value. + +The behavior of this function is best specified in terms of a function + +```agda + summarize : WalletState → Tx → List (Address × TxSummary) + + getAddressSummary + : Address → List (Address × TxSummary) → List TxSummary + getAddressSummary address = + map snd ∘ filter (λ x → fst x == address) +``` + +which summarizes a single transaction. Specifically, the result of `getCustomerHistory` an aggregate of all previous transaction summaries. + +```agda + field + prop_getAddressHistory-summary + : ∀ (s : WalletState) + (c : Customer) + (address : Address) + (tx : Tx) + → (c , address) ∈ listCustomers s + → getCustomerHistory (applyTx tx s) c + ≡ (getAddressSummary address (summarize s tx)) + ++ getCustomerHistory s c +``` + +Importantly, we only track an address if and only if it is a `knownCustomerAddress`. + +```agda + prop_tx-known-address + : ∀ (address : Address) + (s : WalletState) + (tx : Tx) + → (knownCustomerAddress address s ≡ True) + ⟷ (address ∈ map fst (summarize s tx)) +``` + +### Creating transactions + +Finally, we expose an operation + + createPayment + : List (Address × Value) + → PParams → WalletState → Maybe Tx + +which constructs and signs a transaction that sends given values to given addresses. +Here, `PParams` are protocol parameters needed for computation the fee to +include in the `Tx`. + +First, this function will succeed in creating a transaction if there are sufficient +funds available: + +```agda + + field + totalValue : List (Address × Value) → Value + -- totalValue = mconcat ∘ map snd + + maxFee : Value -- maximum fee of a transaction + exceeds : Value → Value → Set + _<>_ : Value → Value → Value + + prop_createPayment-success + : ∀ (s : WalletState) + (pp : PParams) + (destinations : List (Address × Value)) + → exceeds (availableBalance s) (totalValue destinations <> maxFee) + → isJust (createPayment destinations pp s) ≡ True +``` + +TODO: The above statement cannot hold as written, +but it would be highly desirable to have something in this spirit. +(This would be part of a separate specification file +related to `balanceTransaction`.) +Aside from insufficient funds, reasons for failure include: + +* Wallet UTxO is poor + * Few UTxO which are too close to minimum ADA quantity + * UTxO with too many native assets +* Destinations are poor + * `Value` does not carry minimum ADA quantity + * `Value` size too large (native assets, `Datum`, …) +* Combination of both: + * Too many UTxO with small ADA amount + that we need to cover a large `Value` payment. + Example: "Have 1 million x 1 ADA coins, want to send 1 x 1'000'000 ADA coin." + +Second, the transaction sends funds as indicated + +```agda + field + outputs : Tx → List (Address × Value) + + field + prop_createPayment-pays + : ∀ (s : WalletState) + (pp : PParams) + (destinations : List (Address × Value)) + (tx : Tx) + → createPayment destinations pp s ≡ Just tx + → isSubsetOf (outputs tx) destinations ≡ True +``` + +Third, and most importantly, the operation `createPayment` never creates a transaction +whose `received` summary for any tracked index/address pair is non-zero. +In other words, `createPayment` uses change addresses that are distinct +from any address obtained via `createAddress`. + +That said, `createPayment` is free to contribute to the `spent` summary of any address +— the deposit wallet spends funds from any address as it sees fit. + +In other words, we have + +```agda + getAddress : (Address × Value) → Address + getAddress = fst + + field + prop_createPayment-not-known + : ∀ (address : Address) + (s : WalletState) + (pp : PParams) + (destinations : List (Address × Value)) + (tx : Tx) + → knownCustomerAddress address s ≡ True + → createPayment destinations pp s ≡ Just tx + → ¬(address ∈ map getAddress (outputs tx)) +``` + +## Derived Properties + +TODO +From the properties above, one can prove various other properties. +However, this requires and induction principle on `WalletState`, +where we can be certain that other operations do not interfere +with the given ones. + +```agda +{- +prop_getAddressHistory-unknown : Set +prop_getAddressHistory-unknown + = ∀ (s : WalletState) + (addr : Address) + → knownAddress addr s ≡ False + → getAddressHistory addr s ≡ [] +-} +``` +