diff --git a/cabal.project b/cabal.project
index c4ff25d98e3..3c57b26e920 100644
--- a/cabal.project
+++ b/cabal.project
@@ -65,7 +65,6 @@ packages:
lib/cardano-api-extra/
lib/crypto-primitives/
lib/coin-selection/
- lib/deposit-wallet/
lib/delta-chain/
lib/delta-store/
lib/delta-table/
@@ -293,9 +292,6 @@ package cardano-wallet-integration
package cardano-wallet-test-utils
tests: True
-package cardano-deposit-wallet
- tests: True
-
package std-gen-seed
tests: True
diff --git a/lib/deposit-wallet/LICENSE b/lib/deposit-wallet/LICENSE
deleted file mode 100644
index f433b1a53f5..00000000000
--- a/lib/deposit-wallet/LICENSE
+++ /dev/null
@@ -1,177 +0,0 @@
-
- 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/deposit-wallet/cardano-deposit-wallet.cabal b/lib/deposit-wallet/cardano-deposit-wallet.cabal
deleted file mode 100644
index 8d4bea54d21..00000000000
--- a/lib/deposit-wallet/cardano-deposit-wallet.cabal
+++ /dev/null
@@ -1,269 +0,0 @@
-cabal-version: 3.6
-build-type: Simple
-name: cardano-deposit-wallet
-version: 0.2025.1.9
-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: Cardano Foundation (High Assurance Lab)
-maintainer: hal@cardanofoundation.org
-copyright: 2023 Cardano Foundation
-category: Web
-data-files: data/swagger.json
-extra-source-files:
- spec/**/*.lagda.md
-
-common language
- default-language: Haskell2010
- default-extensions:
- NoImplicitPrelude
- OverloadedStrings
-
-common opts-lib
- ghc-options:
- -Wall -Wcompat -Wredundant-constraints -Wincomplete-uni-patterns
- -Wincomplete-record-updates -Wunused-imports -Wunused-packages
-
- if flag(release)
- ghc-options: -O2 -Werror
-
-common opts-exe
- import: opts-lib
- ghc-options: -threaded -rtsopts
-
-common no-delta-table-on-windows
- if !os(windows)
- build-depends: delta-table
- other-modules: Cardano.Wallet.Deposit.IO.DB.Real
-
- else
- other-modules: Cardano.Wallet.Deposit.IO.DB.Stub
-
-flag release
- description: Enable optimization and `-Werror`
- default: False
- manual: True
-
-library
- import: language, opts-lib, no-delta-table-on-windows
- hs-source-dirs: src
- build-depends:
- , async
- , base
- , base16-bytestring
- , base58-bytestring
- , bech32
- , bech32-th
- , bytestring
- , cardano-addresses
- , cardano-balance-tx
- , cardano-crypto
- , cardano-crypto-class
- , cardano-ledger-api
- , cardano-ledger-core
- , cardano-strict-containers
- , cardano-wallet
- , cardano-wallet-network-layer
- , cardano-wallet-primitive
- , cardano-wallet-read
- , containers
- , contra-tracer
- , customer-deposit-wallet-pure
- , delta-store
- , delta-types
- , digest
- , fingertree
- , int-cast
- , io-classes
- , lens
- , MonadRandom
- , monoidal-containers
- , mtl
- , OddWord
- , operational
- , text
- , time
- , transformers
-
- exposed-modules:
- Cardano.Wallet.Deposit.IO
- Cardano.Wallet.Deposit.IO.DB
- Cardano.Wallet.Deposit.IO.Network.Mock
- Cardano.Wallet.Deposit.IO.Network.NodeToClient
- Cardano.Wallet.Deposit.IO.Network.Type
- Cardano.Wallet.Deposit.IO.Resource
- Cardano.Wallet.Deposit.IO.Resource.Event
- Cardano.Wallet.Deposit.Map
- Cardano.Wallet.Deposit.Map.Timed
- Cardano.Wallet.Deposit.Pure
- Cardano.Wallet.Deposit.Pure.API.Address
- Cardano.Wallet.Deposit.Pure.API.TxHistory
- Cardano.Wallet.Deposit.Pure.Balance
- Cardano.Wallet.Deposit.Pure.State.Creation
- Cardano.Wallet.Deposit.Pure.State.Payment
- Cardano.Wallet.Deposit.Pure.State.Payment.Inspect
- Cardano.Wallet.Deposit.Pure.State.Rolling
- Cardano.Wallet.Deposit.Pure.State.Signing
- Cardano.Wallet.Deposit.Pure.State.Submissions
- Cardano.Wallet.Deposit.Pure.State.TxHistory
- Cardano.Wallet.Deposit.Pure.State.Type
- Cardano.Wallet.Deposit.Pure.Submissions
- Cardano.Wallet.Deposit.Pure.UTxO
- Cardano.Wallet.Deposit.Read
- Cardano.Wallet.Deposit.Testing.DSL
- Cardano.Wallet.Deposit.Testing.DSL.ByTime
- Cardano.Wallet.Deposit.Testing.DSL.Types
- Cardano.Wallet.Deposit.Time
- Cardano.Wallet.Deposit.Write
- Cardano.Wallet.Deposit.Write.Keys
-
-test-suite scenario
- import: language, opts-exe
- type: exitcode-stdio-1.0
- hs-source-dirs: test/scenario
- main-is: test-suite-scenario.hs
- build-tool-depends: markdown-unlit:markdown-unlit
- ghc-options: -pgmL markdown-unlit
- build-depends:
- , base
- , bytestring
- , cardano-crypto
- , cardano-wallet-test-utils
- , containers
- , contra-tracer
- , cardano-deposit-wallet
- , delta-store
- , hspec
-
- other-modules:
- Test.Scenario.Blockchain
- Test.Scenario.Wallet.Deposit.Exchanges
- Test.Scenario.Wallet.Deposit.Run
-
-library http
- import: language, opts-lib
- visibility: public
- hs-source-dirs: http
- build-depends:
- , aeson
- , aeson-pretty
- , base
- , bytestring
- , cardano-wallet-read
- , contra-tracer
- , cardano-deposit-wallet
- , cardano-deposit-wallet:rest
- , http-media
- , insert-ordered-containers
- , lens
- , memory
- , openapi3
- , servant
- , servant-server
- , text
- , text-class
-
- exposed-modules:
- Cardano.Wallet.Deposit.HTTP.Server
- Cardano.Wallet.Deposit.HTTP.Types.API
- Cardano.Wallet.Deposit.HTTP.Types.JSON
- Cardano.Wallet.Deposit.HTTP.Types.JSON.Encoding
- Cardano.Wallet.Deposit.HTTP.Types.OpenAPI
-
-library rest
- import: language, opts-lib
- visibility: public
- hs-source-dirs: rest
- build-depends:
- , base
- , bytestring
- , cardano-addresses
- , cardano-crypto
- , cardano-ledger-byron
- , contra-tracer
- , crypto-primitives
- , cardano-deposit-wallet
- , customer-deposit-wallet-pure
- , deepseq
- , delta-store
- , directory
- , filepath
- , memory
- , serialise
- , servant-server
- , text
- , transformers
-
- exposed-modules:
- Cardano.Wallet.Deposit.REST
- Cardano.Wallet.Deposit.REST.Catch
- Cardano.Wallet.Deposit.REST.Start
- Cardano.Wallet.Deposit.REST.Wallet.Create
-
-test-suite unit
- import: language, opts-exe
- type: exitcode-stdio-1.0
- hs-source-dirs: test/unit
- main-is: test-suite-unit.hs
- ghc-options: -Wno-unused-packages
- build-depends:
- , aeson
- , aeson-pretty
- , base
- , base58-bytestring
- , base16-bytestring
- , bech32
- , bech32-th
- , bytestring
- , cardano-addresses
- , address-derivation-discovery
- , cardano-crypto
- , cardano-crypto-class
- , cardano-ledger-api
- , cardano-ledger-core
- , cardano-ledger-core:testlib
- , cardano-ledger-shelley
- , cardano-slotting
- , cardano-wallet-read == 1.0.0.0
- , cardano-wallet-test-utils
- , containers
- , contra-tracer
- , cardano-deposit-wallet
- , customer-deposit-wallet-pure == 0.1.0.0
- , cardano-deposit-wallet:http
- , cardano-deposit-wallet:rest
- , data-default
- , directory
- , hspec
- , hspec-golden
- , lens
- , openapi3
- , pretty-simple
- , QuickCheck
- , serialise
- , temporary
- , text
- , time
- , transformers
- , with-utf8
-
- build-tool-depends: hspec-discover:hspec-discover
- other-modules:
- Cardano.Wallet.Deposit.HTTP.JSON.JSONSpec
- Cardano.Wallet.Deposit.HTTP.OpenAPISpec
- Cardano.Wallet.Deposit.Map.TimedSpec
- Cardano.Wallet.Deposit.Pure.API.AddressSpec
- Cardano.Wallet.Deposit.Pure.API.TransactionSpec
- Cardano.Wallet.Deposit.PureSpec
- Cardano.Wallet.Deposit.RESTSpec
- Cardano.Wallet.Deposit.Write.KeysSpec
- Paths_cardano_deposit_wallet
- Spec
-
-executable cardano-deposit-wallet
- import: language, opts-exe
- hs-source-dirs: exe
- build-depends: base
- main-is: cardano-deposit-wallet.hs
diff --git a/lib/deposit-wallet/data/swagger.json b/lib/deposit-wallet/data/swagger.json
deleted file mode 100644
index 11fdc9e2081..00000000000
--- a/lib/deposit-wallet/data/swagger.json
+++ /dev/null
@@ -1,114 +0,0 @@
-{
- "components": {
- "schemas": {
- "ApiT Address": {
- "format": "hex",
- "type": "string"
- },
- "ApiT ChainPoint": {
- "oneOf": [
- {
- "enum": [
- "genesis"
- ],
- "type": "string"
- },
- {
- "properties": {
- "header_hash": {
- "description": "Hash (Blake2b_256) of a block header.",
- "format": "hex",
- "maxLength": 64,
- "minLength": 64,
- "type": "string"
- },
- "slot_no": {
- "maximum": 1.8446744073709551615e19,
- "minimum": 0,
- "type": "integer"
- }
- },
- "type": "object"
- }
- ]
- },
- "ApiT Customer": {
- "maximum": 2147483647,
- "minimum": 0,
- "type": "integer"
- },
- "ApiT CustomerList": {
- "items": {
- "properties": {
- "address": {
- "format": "hex",
- "type": "string"
- },
- "customer": {
- "maximum": 2147483647,
- "minimum": 0,
- "type": "integer"
- }
- },
- "type": "object"
- },
- "type": "array"
- }
- }
- },
- "info": {
- "description": "This is the API for the deposit wallet",
- "license": {
- "name": "Apache 2",
- "url": "https://www.apache.org/licenses/LICENSE-2.0.html"
- },
- "title": "Cardano Deposit Wallet API",
- "version": "0.0.0.1"
- },
- "openapi": "3.0.0",
- "paths": {
- "/customers": {
- "parameters": [
- {
- "in": "path",
- "name": "customerId",
- "schema": {
- "$ref": "#/components/schemas/ApiT Customer"
- }
- }
- ],
- "put": {
- "responses": {
- "200": {
- "content": {
- "application/json": {
- "schema": {
- "$ref": "#/components/schemas/ApiT Address"
- }
- }
- },
- "description": "Ok"
- }
- },
- "summary": "Add customer"
- }
- },
- "/network/local-tip": {
- "get": {
- "responses": {
- "200": {
- "content": {
- "application/json": {
- "schema": {
- "$ref": "#/components/schemas/ApiT ChainPoint"
- }
- }
- },
- "description": "Ok"
- }
- },
- "summary": "Obtain the chain point until which the wallet is synchronized against the network"
- }
- }
- }
-}
\ No newline at end of file
diff --git a/lib/deposit-wallet/exe/cardano-deposit-wallet.hs b/lib/deposit-wallet/exe/cardano-deposit-wallet.hs
deleted file mode 100644
index 0e8df19982e..00000000000
--- a/lib/deposit-wallet/exe/cardano-deposit-wallet.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-import Prelude
-
-main :: IO ()
-main = pure ()
diff --git a/lib/deposit-wallet/external-signing.md b/lib/deposit-wallet/external-signing.md
deleted file mode 100644
index 258f82acd9f..00000000000
--- a/lib/deposit-wallet/external-signing.md
+++ /dev/null
@@ -1,109 +0,0 @@
-# Signing via external tools.
-
-Here are instructions how to derive respective keys via cardano-addresses, then sign
-transactions CBOR and send the updated CBOR using cardano-cli
-
-Assumptions:
-User have either mnemonic, *phrase.prv*, or extended account private key, *acct.xsk*.
-User know which credential payment index is going to be used, *ix*.
-Unsigned or partially signed CBOR of tx is available.
-
-Goal is to construct CBOR that is input CBOR with properly added witness from the credential signing key
-being a dual of the input credential payment verificiation key.
-
-1. In case of missing *acct.xsk* it can be derived as follows:
-```bash
-$ cat phrase.prv
-attract flight range human visual record trade mango chunk enough satoshi galaxy grit van shrug
-
-$ cardano-address key from-recovery-phrase Shelley < phrase.prv > root.xsk
-$ root.xsk
-$ cat root.xsk
-root_xsk1dqh2lewgwnfzf0kreek8c2zx9csq2d8nh9ku5tvkkxjzypuy5402qnxrl3htj84qxchuxueg3nt7uv50v2mj9vynpdckslyvc24qqxeysye4h2c0cgdemujn8mcprgcstgjvkep30ygu4p3ch983chukqvusp4yk
-
-$ cardano-address key child 1857H/1815H/0H < root.xsk > acct.xsk
-$ cat acct.xsk
-acct_xsk10zeunvvghchkcg8w6achyn3usv642alx8f57rv9kzdzt7yuy540xs4r08lwq576a3v822z9jv8v7kjkjpqxdqtjzt4ukh6w8f57vg0fv6dzaq33pps7hwe5f70cztch0z7kj0552felguwn6n2u74h248g5na6u5
-```
-
-2. Deriving extended verification keys and signing keys for role=0 and address ix=0, and hash that is credential
-```bash
-$ cardano-address key child 0/0 < acct.xsk > key.xsk
-$ cat key.xsk
-addr_xsk14pwgnh4q757kgfjn2w83prmh27kj58ety3acvt0jvx2lwxvy540gmd5gug2egr9dlzv4z04nm9jd26al494w9t6qhlzf07re2myu9mv7syp6aym49c0d97lfg8y0c36vgjv54qnwte6rz3f6x0ltnjqfwcnufn8e
-
-$ cardano-address key public --with-chain-code < key.xsk > key.xvk
-$ cat key.xvk
-addr_xvk1dkqjgyp2tdq0a0tre7qlhprdr88r497k072q0726lhux4xyfxtcfaqgr46fh2ts76ta7jswgl3r5c3yef2pxuhn5x9zn5vl7h8yqjas27h22j
-
-$ cardano-address key hash < key.xvk
-addr_vkh1k70phz25qm9g6uxxguw8znnepqc5uu2mqx9yd7ea8yc7urscytf
-$ cardano-address key hash --hex < key.xvk
-b79e1b895406ca8d70c6471c714e7908314e715b018a46fb3d3931ee
-```
-
-3. Constructing enterprise address for preprod using *key.xvk*
-```bash
-$ cardano-address address payment --network-tag testnet < key.xvk
-addr_test1vzmeuxuf2srv4rtscer3cu2w0yyrznn3tvqc53hm85unrmsg4m9cg
-```
-
-4. Mapping *key.xsk* to the key suitable for cardano-cli
-```bash
-$ cardano-cli key convert-cardano-address-key --shelley-payment-key --signing-key-file key.xsk --out-file key.skey
-$ cat key.skey
-{
- "type": "PaymentExtendedSigningKeyShelley_ed25519_bip32",
- "description": "",
- "cborHex": "5880a85c89dea0f53d642653538f108f7757ad2a1f2b247b862df26195f71984a55e8db688e215940cadf899513eb3d964d56bbfa96ae2af40bfc497f87956c9c2ed6d8124102a5b40febd63cf81fb846d19ce3a97d67f9407f95afdf86a988932f09e8103ae93752e1ed2fbe941c8fc474c44994a826e5e7431453a33feb9c80976"
-}
-```
-Remark: *cborHex* contains:
-- prefix 5880 staking that the bytestring is 128 bytes
-- signing key (64 bytes)
-- verification key (32 bytes)
-- chain code (32 bytes)
-One can confirm this using `cardano-address key inspect`, `cardano-address key public` and `cardano-address key private` options
-
-5. The corresponding verification key
-```bash
-$ cardano-cli key verification-key --signing-key-file key.skey --verification-key-file key.vkey
-$ cat key.vkey
-{
- "type": "PaymentExtendedVerificationKeyShelley_ed25519_bip32",
- "description": "",
- "cborHex": "58406d8124102a5b40febd63cf81fb846d19ce3a97d67f9407f95afdf86a988932f09e8103ae93752e1ed2fbe941c8fc474c44994a826e5e7431453a33feb9c80976"
-}
-```
-Remark: *cborHex* contains:
-- prefix 5840 staking that the bytestring is 64 bytes
-- verification key (32 bytes)
-- chain code (32 bytes)
-
-6. The corresponding key hash (the same like in point 2 above)
-```bash
-$ cardano-cli address key-hash --payment-verification-key-file key.vkey
-b79e1b895406ca8d70c6471c714e7908314e715b018a46fb3d3931ee
-```
-
-7. Signing using cardano-cli. Here let's assume we have unsigned tx and we will use the above keys.
-```bash
-$ cat tx.unsigned
-{
- "type":"Unwitnessed Tx ConwayEra",
- "description":"Ledger Cddl Format",
- "cborHex":"84a400d90102818258204fe1968fc521dffe2bb9799b9c6548e38cd5e1a593c7d43a251eeb92deadc3fe00018282581d60d23d12a37c21b84c8c7838d4bbda848fe7a6b7bfc3f54212238912ec1a000f424082581d601cbb2cdd51437bb9f43bdd1214984e8b2794e0cff25f47ba187494041b0000000253fa1907021a000288b9031a0498a97aa0f5f6"}
-
-$ cardano-cli conway transaction sign --signing-key-file key.skey --testnet-magic 1 --tx-body-file tx.unsigned --out-file tx.signed
-$ cat tx.signed
-{
- "type": "Witnessed Tx ConwayEra",
- "description": "Ledger Cddl Format",
- "cborHex": "84a400d90102818258204fe1968fc521dffe2bb9799b9c6548e38cd5e1a593c7d43a251eeb92deadc3fe00018282581d60d23d12a37c21b84c8c7838d4bbda848fe7a6b7bfc3f54212238912ec1a000f424082581d601cbb2cdd51437bb9f43bdd1214984e8b2794e0cff25f47ba187494041b0000000253fa1907021a000288b9031a0498a97aa100d90102818258206d8124102a5b40febd63cf81fb846d19ce3a97d67f9407f95afdf86a988932f058401a4757dc289f97684339ec766d1fcddfe1ebd50a53d7cccbb71b265e784dd6eb4bf87d5b6c2383e66f1a679f2ac0d97add6a890779096f0802690518223a8c04f5f6"
-}
-```
-
-8. Submitting the signed tx
-```bash
-$ cardano-cli conway transaction submit --tx-file tx.signed --testnet-magic 1
-```
diff --git a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Server.hs b/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Server.hs
deleted file mode 100644
index e16def75ebe..00000000000
--- a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Server.hs
+++ /dev/null
@@ -1,168 +0,0 @@
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Implementation of our HTTP API.
-module Cardano.Wallet.Deposit.HTTP.Server
- ( api
- , server
- )
-where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.HTTP.Types.API
- ( API
- )
-import Cardano.Wallet.Deposit.HTTP.Types.JSON
- ( Address
- , ApiT (..)
- , Customer
- )
-import Cardano.Wallet.Deposit.IO
- ( WalletBootEnv
- )
-import Cardano.Wallet.Deposit.Pure.State.Creation
- ( createMnemonicFromWords
- , credentialsFromEncodedXPub
- , credentialsFromMnemonics
- )
-import Cardano.Wallet.Deposit.REST
- ( WalletResource
- , WalletResourceM
- , customerAddress
- , listCustomers
- )
-import Cardano.Wallet.Deposit.REST.Catch
- ( catchRunWalletResourceM
- )
-import Cardano.Wallet.Deposit.REST.Wallet.Create
- ( PostWalletViaMnemonic (..)
- , PostWalletViaXPub (..)
- )
-import Control.Tracer
- ( Tracer
- )
-import Data.Functor
- ( ($>)
- )
-import Data.Proxy
- ( Proxy (..)
- )
-import Servant
- ( Handler
- , NoContent (..)
- , err500
- , (:<|>) (..)
- )
-import Servant.Server
- ( Server
- )
-
-import qualified Cardano.Wallet.Deposit.REST as REST
-
-{-----------------------------------------------------------------------------
- Types
-------------------------------------------------------------------------------}
-api :: Proxy API
-api = Proxy
-
-server
- :: Tracer IO ()
- -- ^ Tracer for wallet tip changes
- -> Tracer IO String
- -> FilePath
- -> WalletBootEnv IO
- -> WalletResource
- -> Server API
-server wtc tr dbDir wb r =
- listCustomerH r
- :<|> queryAddressH r
- :<|> createWalletViaMnemonic wtc tr dbDir wb r
- :<|> createWalletViaXPub wtc tr dbDir wb r
-
-createWalletViaMnemonic
- :: Tracer IO ()
- -- ^ Tracer for wallet tip changes
- -> Tracer IO String
- -> FilePath
- -> WalletBootEnv IO
- -> WalletResource
- -> PostWalletViaMnemonic
- -> Handler NoContent
-createWalletViaMnemonic
- wtc
- tracer
- dir
- boot
- resource
- (PostWalletViaMnemonic mnemonics' passphrase' users') = do
- case createMnemonicFromWords mnemonics' of
- Left e -> fail $ show e
- Right someMnemonic -> do
- let
- initWallet :: WalletResourceM ()
- initWallet =
- REST.initWallet
- wtc
- tracer
- boot
- dir
- (credentialsFromMnemonics someMnemonic passphrase')
- (fromIntegral users')
- onlyOnWalletIntance resource initWallet $> NoContent
-
-createWalletViaXPub
- :: Tracer IO ()
- -- ^ Tracer for wallet tip changes
- -> Tracer IO String
- -> FilePath
- -> WalletBootEnv IO
- -> WalletResource
- -> PostWalletViaXPub
- -> Handler NoContent
-createWalletViaXPub
- wtc
- tracer
- dir
- boot
- resource
- (PostWalletViaXPub xpubText users') = do
- result <- onlyOnWalletIntance resource initWallet
- case result of
- Left e -> fail e
- Right () -> pure NoContent
- where
- initWallet :: WalletResourceM (Either String ())
- initWallet = case credentialsFromEncodedXPub xpubText of
- Left e -> pure $ Left $ show e
- Right credentials ->
- Right
- <$> REST.initWallet
- wtc
- tracer
- boot
- dir
- credentials
- (fromIntegral users')
-
-listCustomerH
- :: WalletResource
- -> Handler (ApiT [(Customer, Address)])
-listCustomerH wr = ApiT <$> onlyOnWalletIntance wr listCustomers
-
-queryAddressH
- :: WalletResource
- -> ApiT Customer
- -> Handler (ApiT Address)
-queryAddressH wr (ApiT customer) = do
- mAddr <- onlyOnWalletIntance wr $ customerAddress customer
- case mAddr of
- Nothing -> fail $ "Address not found for customer " <> show customer
- Just a -> pure $ ApiT a
-
-onlyOnWalletIntance
- :: WalletResource
- -> WalletResourceM a
- -> Handler a
-onlyOnWalletIntance wr = catchRunWalletResourceM wr err500
diff --git a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/API.hs b/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/API.hs
deleted file mode 100644
index 0732c56fde9..00000000000
--- a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/API.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Servant Type for our HTTP API.
-module Cardano.Wallet.Deposit.HTTP.Types.API
- ( API
- , NetworkAPI
- )
-where
-
-import Cardano.Wallet.Deposit.HTTP.Types.JSON
- ( Address
- , ApiT
- , ChainPoint
- , Customer
- , CustomerList
- )
-import Cardano.Wallet.Deposit.REST.Wallet.Create
- ( PostWalletViaMnemonic
- , PostWalletViaXPub
- )
-import Servant.API
- ( Capture
- , Get
- , JSON
- , Put
- , PutNoContent
- , ReqBody
- , StdMethod (..)
- , Verb
- , (:<|>)
- , (:>)
- )
-
-{-----------------------------------------------------------------------------
- API
-------------------------------------------------------------------------------}
-
-type API =
- "customers"
- :> Get '[JSON] (ApiT CustomerList)
- :<|> "customers"
- :> Capture "customerId" (ApiT Customer)
- :> Put '[JSON] (ApiT Address)
- :<|> "mnemonics"
- :> ReqBody '[JSON] PostWalletViaMnemonic
- :> PutNoContent
- :<|> "xpub"
- :> ReqBody '[JSON] PostWalletViaXPub
- :> PutNoContent
-
-type NetworkAPI =
- "network"
- :> "local-tip"
- :> Verb 'GET 200 '[JSON] (ApiT ChainPoint)
diff --git a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON.hs b/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON.hs
deleted file mode 100644
index 7fe975c6234..00000000000
--- a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON.hs
+++ /dev/null
@@ -1,228 +0,0 @@
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Data types with a JSON schema.
-module Cardano.Wallet.Deposit.HTTP.Types.JSON
- ( ApiT (..)
-
- -- * Re-exports
- , Address
- , Customer
- , CustomerList
- , ChainPoint (..)
- )
-where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.HTTP.Types.JSON.Encoding
- ( ViaText (..)
- )
-import Cardano.Wallet.Deposit.HTTP.Types.OpenAPI
- ( addressSchema
- , chainPointSchema
- , customerListSchema
- , customerSchema
- )
-import Cardano.Wallet.Deposit.Pure
- ( Customer
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- , ChainPoint (..)
- )
-import Cardano.Wallet.Deposit.REST.Wallet.Create
- ( PostWalletViaMnemonic
- , PostWalletViaXPub
- )
-import Control.Applicative
- ( (<|>)
- )
-import Data.Aeson
- ( FromJSON (..)
- , ToJSON (..)
- , object
- , withObject
- , withText
- , (.:)
- , (.=)
- )
-import Data.Aeson.Types
- ( Parser
- )
-import Data.Bifunctor
- ( first
- )
-import Data.ByteArray.Encoding
- ( Base (Base16)
- , convertFromBase
- , convertToBase
- )
-import Data.ByteString.Short
- ( fromShort
- , toShort
- )
-import Data.OpenApi
- ( NamedSchema (..)
- , ToSchema (..)
- )
-import Data.Text
- ( Text
- )
-import Data.Text.Class
- ( FromText (..)
- , TextDecodingError (..)
- , ToText (..)
- , getTextDecodingError
- )
-import Servant
- ( FromHttpApiData (..)
- )
-
-import qualified Cardano.Wallet.Read as Read
-import qualified Cardano.Wallet.Read.Hash as Hash
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-
-{-----------------------------------------------------------------------------
- Additional type definitions
-------------------------------------------------------------------------------}
-
-type CustomerList = [(Customer, Address)]
-
-{-----------------------------------------------------------------------------
- ApiT
-------------------------------------------------------------------------------}
-
-newtype ApiT a = ApiT {unApiT :: a}
- deriving (Eq, Ord, Show)
-
-{-----------------------------------------------------------------------------
- JSON encodings
-------------------------------------------------------------------------------}
-
--- Address
-instance ToText (ApiT Address) where
- toText =
- T.decodeUtf8
- . convertToBase Base16
- . fromShort
- . Read.toShortByteString
- . unApiT
-
-instance FromText (ApiT Address) where
- fromText t = do
- bytes <-
- first textDecodingError
- . convertFromBase Base16
- $ T.encodeUtf8 t
- maybe (Left errInvalidAddress) (Right . ApiT)
- . Read.fromShortByteString
- $ toShort bytes
- where
- errInvalidAddress = TextDecodingError $ "Invalid address: " <> show t
- textDecodingError = TextDecodingError . show
-
--- FIXME: Bech32 encodings
-deriving via ViaText (ApiT Address) instance FromJSON (ApiT Address)
-deriving via ViaText (ApiT Address) instance ToJSON (ApiT Address)
-
-instance ToSchema (ApiT Address) where
- declareNamedSchema _ = do
- pure
- $ NamedSchema
- (Just "ApiT Address")
- addressSchema
-
--- Customer
-instance FromHttpApiData (ApiT Customer) where
- parseUrlPiece = fmap (ApiT . toEnum) . fromText'
-
-instance FromJSON (ApiT Customer) where
- parseJSON = fmap (ApiT . toEnum) . parseJSON
-
-instance ToJSON (ApiT Customer) where
- toJSON = toJSON . fromEnum . unApiT
-
-instance ToSchema (ApiT Customer) where
- declareNamedSchema _ = do
- pure
- $ NamedSchema
- (Just "ApiT Customer")
- customerSchema
-
--- | 'fromText' but with a simpler error type.
-fromText' :: FromText a => Text -> Either Text a
-fromText' = first (T.pack . getTextDecodingError) . fromText
-
-instance ToJSON (ApiT (Customer, Address)) where
- toJSON (ApiT (c, a)) =
- object
- [ "customer" .= toJSON (ApiT c)
- , "address" .= toJSON (ApiT a)
- ]
-
-instance FromJSON (ApiT (Customer, Address)) where
- parseJSON = withObject "ApiT (Customer, Address)" $ \obj -> do
- customerApiT <- obj .: "customer"
- addressApiT <- obj .: "address"
- pure $ ApiT (unApiT customerApiT, unApiT addressApiT)
-
-instance FromJSON (ApiT CustomerList) where
- parseJSON l = do
- custoList <- (parseJSON l :: Parser [ApiT (Customer, Address)])
- pure $ ApiT (unApiT <$> custoList)
-
-instance ToJSON (ApiT CustomerList) where
- toJSON (ApiT cl) = toJSON (toJSON . ApiT <$> cl)
-
-instance ToSchema (ApiT CustomerList) where
- declareNamedSchema _ = do
- pure
- $ NamedSchema
- (Just "ApiT CustomerList")
- customerListSchema
-
-instance ToJSON (ApiT ChainPoint) where
- toJSON (ApiT Read.GenesisPoint) = "genesis"
- toJSON (ApiT (Read.BlockPoint{slotNo, headerHash})) =
- object
- [ "slot_no"
- .= Read.unSlotNo slotNo
- , "header_hash"
- .= Hash.hashToTextAsHex headerHash
- ]
-
-instance FromJSON (ApiT ChainPoint) where
- parseJSON payload = parseOrigin payload <|> parseSlot payload
- where
- parseOrigin = withText "genesis" $ \txt ->
- if txt == "genesis"
- then pure $ ApiT Read.GenesisPoint
- else fail "'genesis' is expected."
- parseSlot = withObject "slot_no" $ \obj -> do
- slotNo <- Read.SlotNo <$> obj .: "slot_no"
- headerHashText <- obj .: "header_hash"
- headerHash <-
- case Hash.hashFromTextAsHex headerHashText of
- Nothing -> fail "invalid 'header_hash'"
- Just hash -> pure hash
- pure $ ApiT Read.BlockPoint{slotNo, headerHash}
-
-instance ToSchema (ApiT ChainPoint) where
- declareNamedSchema _ = do
- pure
- $ NamedSchema
- (Just "ApiT ChainPoint")
- chainPointSchema
-
-instance FromJSON PostWalletViaMnemonic
-
-instance FromJSON PostWalletViaXPub
diff --git a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON/Encoding.hs b/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON/Encoding.hs
deleted file mode 100644
index 2100be31f2e..00000000000
--- a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/JSON/Encoding.hs
+++ /dev/null
@@ -1,81 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
-
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Utilities for mapping data types to/from JSON.
---
-module Cardano.Wallet.Deposit.HTTP.Types.JSON.Encoding
- ( Custom (..)
- , customOptions
- , ViaText (..)
- ) where
-
-import Prelude
-
-import Data.Aeson
- ( FromJSON (..)
- , GFromJSON
- , GToJSON'
- , Options (..)
- , ToJSON (..)
- , Value
- , Zero
- , camelTo2
- , defaultOptions
- , genericParseJSON
- , genericToJSON
- , withText
- )
-import Data.Aeson.Types
- ( Parser
- )
-import Data.Text.Class
- ( FromText (..)
- , ToText (toText)
- )
-import GHC.Generics
- ( Generic
- , Rep
- )
-
-{-----------------------------------------------------------------------------
- Generics
-------------------------------------------------------------------------------}
-newtype Custom a = Custom {unCustom :: a}
-
-instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (Custom a)
- where
- parseJSON = fmap Custom . genericParseJSON customOptions
-
-instance (Generic a, GToJSON' Value Zero (Rep a)) => ToJSON (Custom a)
- where
- toJSON = genericToJSON customOptions . unCustom
-
-customOptions :: Options
-customOptions = defaultOptions
- { fieldLabelModifier = camelTo2 '_' . dropWhile (== '_')
- , omitNothingFields = True
- }
-
-{-----------------------------------------------------------------------------
- Text
-------------------------------------------------------------------------------}
-newtype ViaText a = ViaText {unViaText :: a}
-
-instance FromText a => FromJSON (ViaText a) where
- parseJSON = fmap ViaText . fromTextJSON ""
-instance ToText a => ToJSON (ViaText a) where
- toJSON = toTextJSON . unViaText
-
-eitherToParser :: Show s => Either s a -> Parser a
-eitherToParser = either (fail . show) pure
-
-toTextJSON :: ToText a => a -> Value
-toTextJSON = toJSON . toText
-
-fromTextJSON :: FromText a => String -> Value -> Parser a
-fromTextJSON n = withText n (eitherToParser . fromText)
diff --git a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/OpenAPI.hs b/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/OpenAPI.hs
deleted file mode 100644
index 5e75480cd89..00000000000
--- a/lib/deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Types/OpenAPI.hs
+++ /dev/null
@@ -1,247 +0,0 @@
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Cardano.Wallet.Deposit.HTTP.Types.OpenAPI
- ( generateOpenapi3
- , apiSchema
- , depositPaths
- , depositDefinitions
-
- , customerSchema
- , addressSchema
- , customerListSchema
- , chainPointSchema
- ) where
-
-import Prelude
-
-import Control.Lens
- ( At (..)
- , (&)
- , (.~)
- , (?~)
- )
-import Data.Aeson.Encode.Pretty
- ( encodePretty
- )
-import Data.HashMap.Strict.InsOrd
- ( InsOrdHashMap
- )
-import Data.OpenApi
- ( Definitions
- , HasComponents (..)
- , HasContent (..)
- , HasDescription (..)
- , HasEnum (..)
- , HasFormat (..)
- , HasGet (..)
- , HasIn (..)
- , HasInfo (..)
- , HasItems (..)
- , HasLicense (license)
- , HasMaxLength (..)
- , HasMaximum (..)
- , HasMinLength (..)
- , HasMinimum (..)
- , HasName (..)
- , HasOneOf (..)
- , HasParameters (..)
- , HasPaths (..)
- , HasProperties (..)
- , HasPut (..)
- , HasSchema (..)
- , HasSchemas (..)
- , HasSummary (..)
- , HasTitle (..)
- , HasType (..)
- , HasUrl (..)
- , HasVersion (..)
- , License
- , OpenApi
- , OpenApiItems (..)
- , OpenApiType (..)
- , Operation
- , ParamLocation (..)
- , PathItem
- , Reference (..)
- , Referenced (..)
- , Schema
- , URL (..)
- , _Inline
- )
-import Data.Word
- ( Word64
- )
-import Network.HTTP.Media
- ( MediaType
- )
-
-import qualified Data.ByteString.Lazy.Char8 as BL
-
-generateOpenapi3 :: BL.ByteString
-generateOpenapi3 = encodePretty apiSchema
-
-apiSchema :: OpenApi
-apiSchema :: OpenApi =
- mempty
- & info . title .~ "Cardano Deposit Wallet API"
- & info . version .~ "0.0.0.1"
- & info . description ?~ "This is the API for the deposit wallet"
- & info . license ?~ license'
- & paths .~ depositPaths
- & components . schemas .~ depositDefinitions
-
-license' :: License
-license' =
- "Apache 2"
- & url ?~ URL "https://www.apache.org/licenses/LICENSE-2.0.html"
-
-depositPaths :: InsOrdHashMap FilePath PathItem
-depositPaths =
- [ getCustomersListPath
- , putCustomerPath
- , getLocalTipPath
- ]
-
-depositDefinitions :: Definitions Schema
-depositDefinitions =
- [ ("ApiT Customer", customerSchema)
- , ("ApiT Address", addressSchema)
- , ("ApiT CustomerList", customerListSchema)
- , ("ApiT ChainPoint", chainPointSchema)
- ]
-
--- | Paths
-jsonMediaType :: MediaType
-jsonMediaType = "application/json"
-
-getCustomersListPath :: (FilePath, PathItem)
-getCustomersListPath = ("/customers", pathItem)
- where
- pathItem :: PathItem
- pathItem = mempty & get ?~ operation
- operation :: Operation
- operation =
- mempty
- & summary ?~ summary'
- & at 200 ?~ at200
- summary' = "Obtain the list of customers"
- at200 =
- "Ok"
- & _Inline . content . at jsonMediaType
- ?~ (mempty & schema ?~ Ref (Reference "ApiT CustomerList"))
-
-putCustomerPath :: (FilePath, PathItem)
-putCustomerPath = ("/customers", pathItem)
- where
- pathItem :: PathItem
- pathItem =
- mempty
- & put ?~ operation
- & parameters
- .~ [ Inline
- $ mempty
- & in_ .~ ParamPath
- & name .~ "customerId"
- & schema ?~ Ref (Reference "ApiT Customer")
- ]
- operation :: Operation
- operation =
- mempty
- & summary ?~ summary'
- & at 200 ?~ at200
- summary' = "Add customer"
- at200 =
- "Ok"
- & _Inline . content . at jsonMediaType
- ?~ (mempty & schema ?~ Ref (Reference "ApiT Address"))
-
--- | Input/Output type schemas
-customerSchema :: Schema
-customerSchema =
- mempty
- & type_ ?~ OpenApiInteger
- & minimum_ ?~ 0
- & maximum_ ?~ 2147483647
-
-addressSchema :: Schema
-addressSchema =
- mempty
- & type_ ?~ OpenApiString
- & format ?~ "hex"
-
-customerListItemSchema :: Schema
-customerListItemSchema =
- mempty
- & type_ ?~ OpenApiObject
- & properties
- .~ [ ("customer", Inline customerSchema)
- , ("address", Inline addressSchema)
- ]
-
-customerListSchema :: Schema
-customerListSchema =
- mempty
- & type_ ?~ OpenApiArray
- & items
- ?~ OpenApiItemsObject
- (Inline customerListItemSchema)
-
-getLocalTipPath :: (FilePath, PathItem)
-getLocalTipPath = ("/network/local-tip", pathItem)
- where
- pathItem :: PathItem
- pathItem = mempty & get ?~ operation
- operation :: Operation
- operation =
- mempty
- & summary ?~ summary'
- & at 200 ?~ at200
- summary' = "Obtain the chain point until which the wallet is synchronized against the network"
- at200 =
- "Ok"
- & _Inline . content . at jsonMediaType
- ?~ (mempty & schema ?~ Ref (Reference "ApiT ChainPoint"))
-
-chainPointSchema :: Schema
-chainPointSchema =
- mempty
- & oneOf ?~ [Inline chainPointOriginSchema, Inline chainPointAtSlotSchema]
-
-chainPointOriginSchema :: Schema
-chainPointOriginSchema =
- mempty
- & type_ ?~ OpenApiString
- & enum_ ?~ ["genesis"]
-
-chainPointAtSlotSchema :: Schema
-chainPointAtSlotSchema =
- mempty
- & type_ ?~ OpenApiObject
- & properties
- .~ [ ("slot_no", Inline slotSchema)
- , ("header_hash", Inline headerHashSchema)
- ]
-
-slotSchema :: Schema
-slotSchema =
- mempty
- & type_ ?~ OpenApiInteger
- & minimum_ ?~ 0
- & maximum_ ?~ fromIntegral (maxBound :: Word64)
-
-headerHashSchema :: Schema
-headerHashSchema =
- blake2b_256Schema
- & description ?~ "Hash (Blake2b_256) of a block header."
-
-blake2b_256Schema :: Schema
-blake2b_256Schema =
- mempty
- & type_ ?~ OpenApiString
- & format ?~ "hex"
- & minLength ?~ (32 * hexCharactersPerByte)
- & maxLength ?~ (32 * hexCharactersPerByte)
-
-hexCharactersPerByte :: Integer
-hexCharactersPerByte = 2
diff --git a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs b/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs
deleted file mode 100644
index 66ba07ddd35..00000000000
--- a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs
+++ /dev/null
@@ -1,491 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- 'IO'-based interface to the Deposit Wallet
--- where the wallet is treated as a mutable resource (~ REST).
--- This interface can be mapped one-to-one to a HTTP interface.
-module Cardano.Wallet.Deposit.REST
- ( -- * Types
- WalletResource
- , WalletResourceM
- , ErrDatabase (..)
- , ErrLoadingDatabase (..)
- , ErrCreatingDatabase (..)
- , ErrWalletResource (..)
-
- -- * Running
- , runWalletResourceM
-
- -- * Operations
-
- -- ** Initialization
- , initWallet
- , loadWallet
-
- -- ** Mapping between customers and addresses
- , listCustomers
- , customerAddress
- , addressToCustomer
-
- -- ** Reading from the blockchain
- , getWalletTip
- , availableBalance
- , getTxHistoryByCustomer
- , getTxHistoryByTime
- , WalletIO.ResolveAddress
-
- -- ** Writing to the blockchain
- , createPayment
- , getBIP32PathsForOwnedInputs
- , signTx
- , walletExists
- , walletPublicIdentity
- , deleteWallet
- , deleteTheDepositWalletOnDisk
-
- -- * Internals
- , inspectTx
- , onWalletInstance
- , networkTag
- , resolveCurrentEraTx
- , canSign
- , submitTx
- ) where
-
-import Prelude
-
-import Cardano.Address.Derivation
- ( xpubToBytes
- )
-import Cardano.Crypto.Wallet
- ( XPrv
- , XPub (..)
- , unXPrv
- , unXPub
- , xprv
- , xpub
- )
-import Cardano.Wallet.Address.BIP32
- ( BIP32Path
- )
-import Cardano.Wallet.Deposit.IO
- ( WalletBootEnv
- , WalletPublicIdentity
- , genesisData
- )
-import Cardano.Wallet.Deposit.IO.Resource
- ( ErrResourceExists (..)
- , ErrResourceMissing (..)
- )
-import Cardano.Wallet.Deposit.Pure
- ( CanSign
- , Credentials
- , CurrentEraResolvedTx
- , Customer
- , ErrCreatePayment
- , InspectTx
- , Passphrase
- , Word31
- , fromCredentialsAndGenesis
- )
-import Cardano.Wallet.Deposit.Pure.API.TxHistory
- ( ByCustomer
- , ByTime
- )
-import Cardano.Wallet.Deposit.Pure.State.Creation
- ( accountXPubFromCredentials
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- )
-import Codec.Serialise
- ( Serialise (..)
- , deserialise
- , serialise
- )
-import Control.DeepSeq
- ( deepseq
- )
-import Control.Monad.IO.Class
- ( MonadIO (..)
- )
-import Control.Monad.Trans.Class
- ( lift
- )
-import Control.Monad.Trans.Except
- ( ExceptT (..)
- , runExceptT
- )
-import Control.Monad.Trans.Reader
- ( ReaderT (..)
- , ask
- )
-import Control.Tracer
- ( Tracer (..)
- )
-import Cryptography.Hash.Blake
- ( blake2b160
- )
-import Data.Bifunctor
- ( first
- )
-import Data.ByteArray.Encoding
- ( Base (..)
- , convertToBase
- )
-import Data.ByteString
- ( ByteString
- )
-import Data.List
- ( isPrefixOf
- )
-import Data.Store
- ( Store (..)
- , newStore
- )
-import System.Directory
- ( listDirectory
- , removeFile
- )
-import System.FilePath
- ( ()
- )
-
-import qualified Cardano.Wallet.Deposit.IO as WalletIO
-import qualified Cardano.Wallet.Deposit.IO.Network.Type as Network
-import qualified Cardano.Wallet.Deposit.IO.Resource as Resource
-import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Cardano.Wallet.Deposit.Write as Write
-import qualified Data.ByteString.Char8 as B8
-import qualified Data.ByteString.Lazy as BL
-
-{-----------------------------------------------------------------------------
- Types
-------------------------------------------------------------------------------}
-
--- | Error indicating that the database could not be loaded.
-data ErrLoadingDatabase
- = ErrDatabaseNotFound FilePath
- | ErrDatabaseCorrupted FilePath
- | ErrMultipleDatabases [FilePath]
- deriving (Show, Eq)
-
--- | Error indicating that the database could not be created.
-newtype ErrCreatingDatabase
- = ErrDatabaseAlreadyExists FilePath
- deriving (Show, Eq)
-
--- | Error indicating that the database could not be loaded or created.
-data ErrDatabase
- = ErrLoadingDatabase ErrLoadingDatabase
- | ErrCreatingDatabase ErrCreatingDatabase
- deriving (Show, Eq)
-
--- | Mutable resource that may hold a 'WalletInstance'.
-type WalletResource =
- Resource.Resource ErrDatabase WalletIO.WalletInstance
-
--- | Error indicating that the 'WalletResource' does not hold a wallet.
-data ErrWalletResource
- = ErrNoWallet (Resource.ErrResourceMissing ErrDatabase)
- | ErrWalletPresent
- (Resource.ErrResourceExists ErrDatabase WalletIO.WalletInstance)
-
-instance Show ErrWalletResource where
- show = \case
- ErrNoWallet e -> case e of
- ErrNotInitialized -> "Wallet is not initialized"
- ErrStillInitializing -> "Wallet is still initializing"
- ErrVanished e' -> "Wallet absent and vanished: " <> show e'
- ErrFailedToInitialize e' ->
- "Wallet failed to initialize (no wallet): "
- <> show e'
- ErrClosing -> "Wallet is closing"
- ErrWalletPresent e -> case e of
- ErrAlreadyInitializing -> "Wallet is already initializing"
- ErrAlreadyInitialized _ -> "Wallet is already initialized"
- ErrAlreadyVanished e' -> "Wallet vanished: " <> show e'
- ErrAlreadyFailedToInitialize e' ->
- "Wallet failed to initialize (wallet present): "
- <> show e'
- ErrAlreadyClosing -> "Wallet is already closing"
-
--- | Monad for acting on a 'WalletResource'.
-type WalletResourceM =
- ReaderT WalletResource (ExceptT ErrWalletResource IO)
-
--- | Run a 'WalletResourceM' action on a 'WalletResource'.
-runWalletResourceM
- :: WalletResourceM a
- -> WalletResource
- -> IO (Either ErrWalletResource a)
-runWalletResourceM action resource =
- runExceptT (runReaderT action resource)
-
--- | Run an 'IO' function on the 'WalletInstance'.
-onWalletInstance
- :: (WalletIO.WalletInstance -> IO a)
- -> WalletResourceM a
-onWalletInstance action = ReaderT $ \resource ->
- ExceptT
- $ first ErrNoWallet <$> Resource.onResource action resource
-
-{-----------------------------------------------------------------------------
- Initialization
-------------------------------------------------------------------------------}
-
--- | Prefix for deposit wallets on disk.
-depositPrefix :: String
-depositPrefix = "deposit-"
-
--- | Scan a directory for deposit wallets.
-scanDirectoryForDepositPrefix :: FilePath -> IO [FilePath]
-scanDirectoryForDepositPrefix dir = do
- files <- listDirectory dir
- pure $ filter (depositPrefix `isPrefixOf`) files
-
-deleteTheDepositWalletOnDisk :: FilePath -> IO ()
-deleteTheDepositWalletOnDisk dir = do
- ds <- scanDirectoryForDepositPrefix dir
- case ds of
- [d] -> removeFile (dir d)
- _ -> pure ()
-
--- | Try to open an existing wallet
-findTheDepositWalletOnDisk
- :: WalletBootEnv IO
- -> FilePath
- -- ^ Path to the wallet database directory
- -> (Either ErrLoadingDatabase WalletIO.WalletStore -> IO a)
- -- ^ Action to run if the wallet is found
- -> IO a
-findTheDepositWalletOnDisk env dir action = do
- ds <- scanDirectoryForDepositPrefix dir
- case ds of
- [d] -> do
- (credentials, customers) <-
- deserialise <$> BL.readFile (dir d)
- let state =
- fromCredentialsAndGenesis
- credentials
- (fromIntegral @Int customers)
- (genesisData env)
- store <- newStore
- writeS store state
- action $ Right store
- [] -> action $ Left $ ErrDatabaseNotFound dir
- ds' -> action $ Left $ ErrMultipleDatabases ((dir ) <$> ds')
-
-instance Serialise XPub where
- encode = encode . unXPub
- decode = do
- b <- decode
- case xpub b of
- Right x -> pure x
- Left e -> fail e
-
-instance Serialise XPrv where
- encode = encode . unXPrv
- decode = do
- b :: ByteString <- decode
- case xprv b of
- Right x -> pure x
- Left e -> fail e
-
-instance Serialise Credentials
-
--- | Try to create a new wallet
-createTheDepositWalletOnDisk
- :: Tracer IO String
- -- ^ Tracer for logging
- -> FilePath
- -- ^ Path to the wallet database directory
- -> Credentials
- -- ^ Id of the wallet
- -> Word31
- -- ^ Maximum customer index
- -> (Maybe WalletIO.WalletStore -> IO a)
- -- ^ Action to run if the wallet is created
- -> IO a
-createTheDepositWalletOnDisk _tr dir credentials users action = do
- ds <- scanDirectoryForDepositPrefix dir
- case ds of
- [] -> do
- let fp = dir depositPrefix <> hashWalletId credentials
- BL.writeFile fp
- $ serialise (credentials, fromIntegral users :: Int)
- store <- newStore
- action $ Just store
- _ -> do
- action Nothing
- where
- hashWalletId :: Credentials -> String
- hashWalletId =
- B8.unpack
- . convertToBase Base16
- . blake2b160
- . xpubToBytes
- . accountXPubFromCredentials
-
--- | Load an existing wallet from disk.
-loadWallet
- :: Tracer IO ()
- -- ^ Tracer for wallet tip changes
- -> WalletIO.WalletBootEnv IO
- -- ^ Environment for the wallet
- -> FilePath
- -- ^ Path to the wallet database directory
- -> WalletResourceM ()
-loadWallet wtc bootEnv dir = do
- let action
- :: (WalletIO.WalletInstance -> IO b) -> IO (Either ErrDatabase b)
- action f = findTheDepositWalletOnDisk bootEnv dir $ \case
- Right wallet ->
- Right
- <$> WalletIO.withWalletLoad wtc
- (WalletIO.WalletEnv bootEnv wallet)
- f
- Left e -> pure $ Left $ ErrLoadingDatabase e
- resource <- ask
- lift
- $ ExceptT
- $ first ErrWalletPresent
- <$> Resource.putResource action resource
-
--- | Initialize a new wallet from an 'XPub'.
-initWallet
- :: Tracer IO ()
- -- ^ Tracer for wallet tip changes
- -> Tracer IO String
- -- ^ Tracer for logging
- -> WalletIO.WalletBootEnv IO
- -- ^ Environment for the wallet
- -> FilePath
- -- ^ Path to the wallet database directory
- -> Credentials
- -- ^ Id of the wallet
- -> Word31
- -- ^ Max number of users ?
- -> WalletResourceM ()
-initWallet wtc tr bootEnv dir credentials users = do
- let action
- :: (WalletIO.WalletInstance -> IO b) -> IO (Either ErrDatabase b)
- action f = createTheDepositWalletOnDisk tr dir credentials users $ \case
- Just wallet -> do
- fmap Right
- $ WalletIO.withWalletInit wtc
- (WalletIO.WalletEnv bootEnv wallet)
- credentials
- users
- $ \i -> do
- addresses <- map snd <$> WalletIO.listCustomers i
- addresses `deepseq` f i
- Nothing ->
- pure
- $ Left
- $ ErrCreatingDatabase
- $ ErrDatabaseAlreadyExists dir
- resource <- ask
- lift
- $ ExceptT
- $ first ErrWalletPresent
- <$> Resource.putResource action resource
-
-deleteWallet :: FilePath -> WalletResourceM ()
-deleteWallet dir = do
- resource <- ask
- lift
- $ ExceptT
- $ first ErrNoWallet
- <$> Resource.closeResource resource
- liftIO $ deleteTheDepositWalletOnDisk dir
-
-walletExists :: FilePath -> IO Bool
-walletExists dir = do
- r <- scanDirectoryForDepositPrefix dir
- case r of
- [] -> pure False
- _ -> pure True
-
-walletPublicIdentity :: WalletResourceM WalletPublicIdentity
-walletPublicIdentity = onWalletInstance WalletIO.walletPublicIdentity
-
-{-----------------------------------------------------------------------------
- Operations
-------------------------------------------------------------------------------}
-
--- | List all tracked customers addresses.
-listCustomers :: WalletResourceM [(Customer, Address)]
-listCustomers = onWalletInstance WalletIO.listCustomers
-
--- | Retrieve the address for a customer if it's tracked by the wallet.
-customerAddress :: Customer -> WalletResourceM (Maybe Address)
-customerAddress = onWalletInstance . WalletIO.customerAddress
-
-addressToCustomer :: WalletResourceM WalletIO.ResolveAddress
-addressToCustomer = onWalletInstance WalletIO.addressToCustomer
-
-{-----------------------------------------------------------------------------
- Operations
- Reading from the blockchain
-------------------------------------------------------------------------------}
-getWalletTip :: WalletResourceM Read.ChainPoint
-getWalletTip = onWalletInstance WalletIO.getWalletTip
-
-availableBalance :: WalletResourceM Read.Value
-availableBalance = onWalletInstance WalletIO.availableBalance
-
-getTxHistoryByCustomer
- :: WalletResourceM ByCustomer
-getTxHistoryByCustomer = onWalletInstance WalletIO.getTxHistoryByCustomer
-
-getTxHistoryByTime
- :: WalletResourceM ByTime
-getTxHistoryByTime = onWalletInstance WalletIO.getTxHistoryByTime
-
-networkTag :: WalletResourceM Read.NetworkTag
-networkTag = onWalletInstance WalletIO.networkTag
-
-{-----------------------------------------------------------------------------
- Operations
- Writing to blockchain
-------------------------------------------------------------------------------}
-
-createPayment
- :: [(Address, Read.Value)]
- -> WalletResourceM (Either ErrCreatePayment CurrentEraResolvedTx)
-createPayment = onWalletInstance . WalletIO.createPayment
-
-getBIP32PathsForOwnedInputs
- :: Write.Tx
- -> WalletResourceM [BIP32Path]
-getBIP32PathsForOwnedInputs =
- onWalletInstance . WalletIO.getBIP32PathsForOwnedInputs
-
-canSign :: WalletResourceM CanSign
-canSign = onWalletInstance WalletIO.canSign
-
-signTx
- :: Write.Tx
- -> Passphrase
- -> WalletResourceM (Maybe Write.Tx)
-signTx tx = onWalletInstance . WalletIO.signTx tx
-
-inspectTx
- :: CurrentEraResolvedTx
- -> WalletResourceM InspectTx
-inspectTx = onWalletInstance . WalletIO.inspectTx
-
-resolveCurrentEraTx :: Write.Tx -> WalletResourceM CurrentEraResolvedTx
-resolveCurrentEraTx = onWalletInstance . WalletIO.resolveCurrentEraTx
-
-submitTx :: Write.Tx -> WalletResourceM (Either Network.ErrPostTx ())
-submitTx = onWalletInstance . WalletIO.submitTx
diff --git a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Catch.hs b/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Catch.hs
deleted file mode 100644
index b4a331c9b7b..00000000000
--- a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Catch.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Cardano.Wallet.Deposit.REST.Catch
- ( catchRunWalletResourceM
- )
-where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.REST
- ( WalletResource
- , WalletResourceM
- , runWalletResourceM
- )
-import Control.Exception
- ( SomeException (..)
- , try
- )
-import Control.Monad.IO.Class
- ( MonadIO (..)
- )
-import Control.Monad.Trans.Except
- ( throwE
- )
-import Servant
- ( Handler (..)
- , ServerError (..)
- )
-
-import qualified Data.ByteString.Lazy.Char8 as BL
-
--- | Catch and run a 'WalletResourceM' action, converting any exceptions to
--- 'ServerError'.
-catchRunWalletResourceM
- :: WalletResource
- -> ServerError
- -> WalletResourceM a
- -> Handler a
-catchRunWalletResourceM s se f = do
- er <- liftIO $ try $ runWalletResourceM f s
- case er of
- Right (Right a) ->
- pure a
- Right (Left e) ->
- Handler $ throwE $ se{errBody = BL.pack $ show e}
- Left (SomeException e) ->
- Handler $ throwE $ se{errBody = BL.pack $ show e}
diff --git a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Start.hs b/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Start.hs
deleted file mode 100644
index 89236c97bf6..00000000000
--- a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Start.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Cardano.Wallet.Deposit.REST.Start
- ( loadDepositWalletFromDisk
- , newBootEnv
- )
-where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.IO
- ( WalletBootEnv (..)
- )
-import Cardano.Wallet.Deposit.IO.Network.NodeToClient
- ( CardanoBlock
- , NetworkLayer
- , StandardCrypto
- , fromNetworkLayer
- )
-import Cardano.Wallet.Deposit.REST
- ( WalletResource
- , loadWallet
- , runWalletResourceM
- , walletExists
- )
-import Control.Monad
- ( when
- )
-import Control.Monad.IO.Class
- ( MonadIO (..)
- )
-import Control.Monad.Trans.Except
- ( ExceptT (..)
- , runExceptT
- )
-import Control.Tracer
- ( Tracer
- , stdoutTracer
- , traceWith
- )
-import Data.Functor.Contravariant
- ( (>$<)
- )
-
-import qualified Cardano.Chain.Genesis as Byron
-import qualified Cardano.Wallet.Deposit.Read as Read
-
-lg :: (MonadIO m, Show a) => Tracer IO String -> String -> a -> m ()
-lg tr p x = liftIO $ traceWith tr $ p <> ": " <> show x
-
-loadDepositWalletFromDisk
- :: Tracer IO ()
- -- ^ Tracer for wallet tip changes
- -> Tracer IO String
- -> FilePath
- -> WalletBootEnv IO
- -> WalletResource
- -> IO ()
-loadDepositWalletFromDisk wtc tr dir env resource = do
- result <- flip runWalletResourceM resource $ do
- test <- liftIO $ walletExists dir
- when test $ do
- lg tr "Loading wallet from" dir
- loadWallet wtc env dir
- lg tr "Wallet loaded from" dir
- pure test
- case result of
- Left e -> error $ show e
- Right _ -> pure ()
-
-newBootEnv
- :: Maybe FilePath
- -> NetworkLayer IO (CardanoBlock StandardCrypto)
- -> IO (WalletBootEnv IO)
-newBootEnv genesisFile nl = do
- eGenesisData <- runExceptT $ case genesisFile of
- Nothing -> ExceptT $ pure $ Right Read.mockGenesisDataMainnet
- Just file -> fst <$> Byron.readGenesisData file
- case eGenesisData of
- Left e -> error $ show e
- Right genesisData' ->
- return
- $ WalletBootEnv
- (show >$< stdoutTracer)
- genesisData'
- (fromNetworkLayer nl)
diff --git a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Wallet/Create.hs b/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Wallet/Create.hs
deleted file mode 100644
index 715b4d413ab..00000000000
--- a/lib/deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Wallet/Create.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-
-module Cardano.Wallet.Deposit.REST.Wallet.Create
- ( PostWalletViaMnemonic (..)
- , PostWalletViaXPub (..)
- )
-where
-
-import Prelude
-
-import Data.Text
- ( Text
- )
-import GHC.Generics
- ( Generic
- )
-
--- | Data for a request to create a wallet via a mnemonic.
-data PostWalletViaMnemonic = PostWalletViaMnemonic
- { mnemonics :: Text
- , password :: Text
- , trackedCustomers :: Int
- }
- deriving (Generic)
-
--- | Data for a request to create a wallet via an extended public key.
-data PostWalletViaXPub = PostWalletViaXPub
- { xpub :: Text
- , trackedCustomers :: Int
- }
- deriving (Generic)
diff --git a/lib/deposit-wallet/spec/cardano-deposit-wallet.lagda.md b/lib/deposit-wallet/spec/cardano-deposit-wallet.lagda.md
deleted file mode 100644
index f2c62a03439..00000000000
--- a/lib/deposit-wallet/spec/cardano-deposit-wallet.lagda.md
+++ /dev/null
@@ -1,418 +0,0 @@
-# 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 ≡ []
--}
-```
-
diff --git a/lib/deposit-wallet/spec/openapi/index.html b/lib/deposit-wallet/spec/openapi/index.html
deleted file mode 100644
index 75d1ff89a92..00000000000
--- a/lib/deposit-wallet/spec/openapi/index.html
+++ /dev/null
@@ -1,17 +0,0 @@
-
-
-
- Customer Deposit Wallet API
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs
deleted file mode 100644
index 3bec178e0a2..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs
+++ /dev/null
@@ -1,417 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE RecordWildCards #-}
-
-module Cardano.Wallet.Deposit.IO
- ( -- * Types
- WalletEnv (..)
- , WalletStore
- , WalletBootEnv (..)
- , WalletPublicIdentity (..)
- , WalletInstance
-
- -- * Operations
-
- -- ** Initialization
- , withWalletInit
- , Word31
- , withWalletLoad
- , walletPublicIdentity
-
- -- ** Mapping between customers and addresses
- , listCustomers
- , customerAddress
- , addressToCustomer
- , ResolveAddress
-
- -- ** Reading from the blockchain
- , getWalletTip
- , availableBalance
- , getTxHistoryByCustomer
- , getTxHistoryByTime
- , getCustomerDeposits
- , getAllDeposits
-
- -- ** Writing to the blockchain
-
- -- *** Create transactions
- , createPayment
- , inspectTx
-
- -- *** Sign transactions
- , getBIP32PathsForOwnedInputs
- , signTx
-
- -- *** Submit transactions
- , submitTx
- , listTxsInSubmission
-
- -- * Internals
- , onWalletState
- , networkTag
- , readWalletState
- , resolveCurrentEraTx
- , canSign
- ) where
-
-import Prelude
-
-import Cardano.Wallet.Address.BIP32
- ( BIP32Path
- )
-import Cardano.Wallet.Deposit.IO.Network.Type
- ( NetworkEnv (slotToUTCTime)
- )
-import Cardano.Wallet.Deposit.Pure
- ( Credentials
- , CurrentEraResolvedTx
- , Customer
- , ValueTransfer
- , WalletPublicIdentity (..)
- , WalletState
- , Word31
- )
-import Cardano.Wallet.Deposit.Pure.API.TxHistory
- ( ByCustomer
- , ByTime
- , LookupTimeFromSlot
- )
-import Cardano.Wallet.Deposit.Pure.State.Creation
- ( CanSign
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- , TxId
- , WithOrigin
- )
-import Cardano.Wallet.Network.Checkpoints.Policy
- ( defaultPolicy
- )
-import Control.Tracer
- ( Tracer
- , contramap
- , traceWith
- )
-import Data.Bifunctor
- ( first
- )
-import Data.List.NonEmpty
- ( NonEmpty
- )
-import Data.Map.Strict
- ( Map
- )
-import Data.Time
- ( UTCTime
- )
-
-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
-------------------------------------------------------------------------------}
-
--- | The environment needed to initialize a wallet, before a database is
--- connected.
-data WalletBootEnv m = WalletBootEnv
- { logger :: Tracer m WalletLog
- -- ^ Logger for the wallet.
- , genesisData :: Read.GenesisData
- -- ^ Genesis data for the wallet.
- , networkEnv :: Network.NetworkEnv m (Read.EraValue Read.Block)
- -- ^ Network environment for the wallet.
- }
-
--- | The wallet store type.
-type WalletStore = Store.UpdateStore IO Wallet.DeltaWalletState
-
--- | The full environment needed to run a wallet.
-data WalletEnv m = WalletEnv
- { bootEnv :: WalletBootEnv m
- -- ^ The boot environment.
- , store :: WalletStore
- -- ^ The store for the wallet.
- }
-
-data WalletInstance = WalletInstance
- { env :: WalletEnv IO
- , walletState :: DBVar.DBVar IO 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{walletState} =
- Delta.onDBVar walletState
-
--- FIXME: Propagation of exceptions from Pure to IO.
-
--- | Convenience to read the 'WalletState'.
---
--- Use 'onWalletState' if you want to use the result in an atomic update.
-readWalletState :: WalletInstance -> IO WalletState
-readWalletState WalletInstance{walletState} =
- DBVar.readDBVar walletState
-
-{-----------------------------------------------------------------------------
- Operations
- Initialization
-------------------------------------------------------------------------------}
-
--- | Initialize a new wallet in the given environment.
-withWalletInit
- :: Tracer IO () -- wallet tip changes
- -> WalletEnv IO
- -> Credentials
- -> Word31
- -> (WalletInstance -> IO a)
- -> IO a
-withWalletInit
- wtc
- env@WalletEnv
- { bootEnv = WalletBootEnv{genesisData}
- , ..
- }
- credentials
- customers
- action = do
- walletState <-
- DBVar.initDBVar store
- $ Wallet.fromCredentialsAndGenesis
- credentials
- customers
- genesisData
- withWalletDBVar wtc env walletState action
-
--- | Load an existing wallet from the given environment.
-withWalletLoad
- :: Tracer IO () -- wallet tip changes
- -> WalletEnv IO
- -> (WalletInstance -> IO a)
- -> IO a
-withWalletLoad wtc env@WalletEnv{..} action = do
- walletState <- DBVar.loadDBVar store
- withWalletDBVar wtc env walletState action
-
-withWalletDBVar
- :: Tracer IO () -- wallet tip changes
- -> WalletEnv IO
- -> DBVar.DBVar IO Wallet.DeltaWalletState
- -> (WalletInstance -> IO a)
- -> IO a
-withWalletDBVar
- wtc
- env@WalletEnv{bootEnv = WalletBootEnv{logger, networkEnv}}
- walletState
- action = do
- let w = WalletInstance{env, walletState}
- Async.withAsync (doChainSync w) $ \_ -> action w
- where
- doChainSync = Network.chainSync networkEnv trChainSync . chainFollower
- trChainSync = contramap (\_ -> WalletLogDummy) logger
- chainFollower w =
- Network.ChainFollower
- { checkpointPolicy = defaultPolicy
- , readChainPoints = do
- walletTip <- Wallet.getWalletTip <$> readWalletState w
- pure
- [ walletTip
- , Read.GenesisPoint
- ]
- , rollForward = rollForward w wtc
- , rollBackward = rollBackward w
- }
-
-{-----------------------------------------------------------------------------
- Operations
-------------------------------------------------------------------------------}
-listCustomers :: WalletInstance -> IO [(Customer, Address)]
-listCustomers w =
- Wallet.listCustomers <$> readWalletState w
-
-customerAddress :: Customer -> WalletInstance -> IO (Maybe Address)
-customerAddress c w = Wallet.customerAddress c <$> readWalletState w
-
-walletPublicIdentity :: WalletInstance -> IO WalletPublicIdentity
-walletPublicIdentity w = do
- state <- readWalletState w
- pure
- $ WalletPublicIdentity
- { pubXpub = Wallet.walletXPub state
- , pubNextUser = Wallet.trackedCustomers state
- }
-
-type ResolveAddress = Address -> Maybe Customer
-
-addressToCustomer :: WalletInstance -> IO ResolveAddress
-addressToCustomer w = do
- state <- readWalletState w
- pure $ flip Wallet.addressToCustomer state
-
-{-----------------------------------------------------------------------------
- Operations
- Reading from the blockchain
-------------------------------------------------------------------------------}
-getWalletTip :: WalletInstance -> IO Read.ChainPoint
-getWalletTip w =
- Wallet.getWalletTip <$> readWalletState w
-
-availableBalance :: WalletInstance -> IO Read.Value
-availableBalance w =
- Wallet.availableBalance <$> readWalletState w
-
-getTxHistoryByCustomer :: WalletInstance -> IO ByCustomer
-getTxHistoryByCustomer w =
- Wallet.getTxHistoryByCustomer <$> readWalletState w
-
-getTxHistoryByTime :: WalletInstance -> IO ByTime
-getTxHistoryByTime w = Wallet.getTxHistoryByTime <$> readWalletState w
-
-getCustomerDeposits
- :: WalletInstance
- -> Customer
- -> Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
- -> IO (Map TxId ValueTransfer)
-getCustomerDeposits w c i =
- Wallet.getCustomerDeposits c i <$> readWalletState w
-
-getAllDeposits
- :: WalletInstance
- -> Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
- -> IO (Map Customer ValueTransfer)
-getAllDeposits w i =
- Wallet.getAllDeposits i <$> readWalletState w
-
-rollForward
- :: WalletInstance
- -> Tracer IO () -- wallet tip changes
- -> NonEmpty (Read.EraValue Read.Block)
- -> tip
- -> IO ()
-rollForward w wtc blocks _nodeTip = do
- timeFromSlot <- slotResolver w
- onWalletState w
- $ Delta.update
- $ Delta.Replace
- . Wallet.rollForwardMany
- timeFromSlot
- blocks
- traceWith wtc ()
- x <- readWalletState w
- x `seq` pure ()
-
-rollBackward
- :: WalletInstance -> Read.ChainPoint -> IO Read.ChainPoint
-rollBackward w point = do
- timeFromSlot <- slotResolver w
- onWalletState w
- $ Delta.updateWithResult
- $ first Delta.Replace . Wallet.rollBackward timeFromSlot point
-
--- | Compute a slot resolver for the given slots.
-slotResolver
- :: WalletInstance
- -> IO LookupTimeFromSlot
-slotResolver w = do
- slotToUTCTime
- $ networkEnv
- $ bootEnv
- $ env w
-
-networkTag :: WalletInstance -> IO Read.NetworkTag
-networkTag w = do
- Wallet.networkTag <$> readWalletState w
-
-{-----------------------------------------------------------------------------
- Operations
- Constructing transactions
-------------------------------------------------------------------------------}
-
-createPayment
- :: [(Address, Read.Value)]
- -> WalletInstance
- -> IO (Either Wallet.ErrCreatePayment CurrentEraResolvedTx)
-createPayment a w = do
- timeTranslation <- Network.getTimeTranslation network
- pparams <-
- Network.currentPParams network
- Wallet.createPayment pparams timeTranslation a <$> readWalletState w
- where
- network = networkEnv $ bootEnv $ env w
-
-inspectTx
- :: CurrentEraResolvedTx
- -> WalletInstance
- -> IO Wallet.InspectTx
-inspectTx tx w = flip Wallet.inspectTx tx <$> readWalletState w
-
-resolveCurrentEraTx
- :: Write.Tx
- -> WalletInstance
- -> IO CurrentEraResolvedTx
-resolveCurrentEraTx tx w =
- Wallet.resolveCurrentEraTx tx <$> readWalletState w
-
-{-----------------------------------------------------------------------------
- Operations
- Signing transactions
-------------------------------------------------------------------------------}
-
-canSign :: WalletInstance -> IO CanSign
-canSign w = do
- Wallet.canSign <$> readWalletState w
-
-getBIP32PathsForOwnedInputs
- :: Write.Tx -> WalletInstance -> IO [BIP32Path]
-getBIP32PathsForOwnedInputs a w =
- Wallet.getBIP32PathsForOwnedInputs a <$> readWalletState w
-
-signTx
- :: Write.Tx -> Wallet.Passphrase -> WalletInstance -> IO (Maybe Write.Tx)
-signTx a b w = Wallet.signTx a b <$> readWalletState w
-
-{-----------------------------------------------------------------------------
- Operations
- Pending transactions
-------------------------------------------------------------------------------}
-
-submitTx
- :: Write.Tx -> WalletInstance -> IO (Either Network.ErrPostTx ())
-submitTx tx w = do
- e <- Network.postTx network tx
- case e of
- Right _ -> do
- onWalletState w
- $ Delta.update
- $ Delta.Replace . Wallet.addTxSubmission tx
- pure $ Right ()
- _ -> pure e
- where
- network = networkEnv $ bootEnv $ env w
-
-listTxsInSubmission :: WalletInstance -> IO [Write.Tx]
-listTxsInSubmission w =
- Wallet.listTxsInSubmission <$> readWalletState w
-
-{-----------------------------------------------------------------------------
- Logging
-------------------------------------------------------------------------------}
-data WalletLog
- = WalletLogDummy
- deriving (Show)
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs
deleted file mode 100644
index e332dacf206..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Cardano.Wallet.Deposit.IO.DB
- (
-#ifndef mingw32_HOST_OS
- module Cardano.Wallet.Deposit.IO.DB.Real
-#endif
- )
-
-where
-
-#ifdef mingw32_HOST_OS
-import Cardano.Wallet.Deposit.IO.DB.Stub
- ()
-#else
-import Cardano.Wallet.Deposit.IO.DB.Real
-#endif
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Real.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Real.hs
deleted file mode 100644
index 3d4e4e85b73..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Real.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# LANGUAGE Rank2Types #-}
-
-module Cardano.Wallet.Deposit.IO.DB.Real
- ( Connection
- , withSqliteFile
- , withSqliteInMemory
- , SqlM
- , runSqlM
- , DBLog (..)
- ) where
-
-import Prelude
-
-import Control.Tracer
- ( Tracer
- , traceWith
- )
-import Database.Table.SQLite.Simple
- ( Connection
- , SqlM
- , runSqlM
- , withConnection
- )
-
-{-----------------------------------------------------------------------------
- SqlContext
-------------------------------------------------------------------------------}
-
--- | Acquire and release an SQLite 'Connection' in memory.
-withSqliteInMemory
- :: Tracer IO DBLog
- -- ^ Logging
- -> (Connection -> IO a)
- -- ^ Action to run
- -> IO a
-withSqliteInMemory tr = withSqliteFile tr ":memory:"
-
--- | Acquire and release an SQLite 'Connection' from a file.
-withSqliteFile
- :: Tracer IO DBLog
- -- ^ Logging
- -> FilePath
- -- ^ Database file
- -> (Connection -> IO a)
- -- ^ Action to run
- -> IO a
-withSqliteFile tr filepath action =
- withConnection filepath $ \conn -> do
- traceWith tr $ MsgStartConnection filepath
- result <- action conn
- traceWith tr $ MsgDoneConnection filepath
- pure result
-
-{-------------------------------------------------------------------------------
- Logging
--------------------------------------------------------------------------------}
-
-data DBLog
- = MsgStartConnection FilePath
- | MsgDoneConnection FilePath
- deriving (Show, Eq)
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Stub.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Stub.hs
deleted file mode 100644
index ec9a50f4454..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/DB/Stub.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-module Cardano.Wallet.Deposit.IO.DB.Stub ()
-where
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs
deleted file mode 100644
index ee3726965dc..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs
+++ /dev/null
@@ -1,97 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Mock implementation of a 'NetworkEnv'.
-module Cardano.Wallet.Deposit.IO.Network.Mock
- ( newNetworkEnvMock
- ) where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.IO.Network.Type
- ( NetworkEnv (..)
- )
-import Cardano.Wallet.Network
- ( ChainFollower (..)
- )
-import Control.Concurrent.Class.MonadSTM
- ( MonadSTM
- , atomically
- , modifyTVar
- , newTVarIO
- , readTVar
- , readTVarIO
- , writeTVar
- )
-import Control.Monad
- ( forever
- )
-import Control.Monad.Class.MonadTimer
- ( MonadDelay
- , threadDelay
- )
-import Data.Foldable
- ( for_
- )
-import Data.List.NonEmpty
- ( NonEmpty ((:|))
- )
-
-import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Cardano.Wallet.Deposit.Time as Time
-import qualified Cardano.Wallet.Deposit.Write as Write
-
-{-----------------------------------------------------------------------------
- Mock implementation of 'NetworkEnv'
-------------------------------------------------------------------------------}
-newNetworkEnvMock
- :: (MonadDelay m, MonadSTM m)
- => m (NetworkEnv m (Read.Block Read.Conway))
-newNetworkEnvMock = do
- mchain <- newTVarIO []
- mtip <- newTVarIO Read.GenesisPoint
- mfollowers <- newTVarIO []
-
- let registerAndUpdate follower = do
- _ <- rollBackward follower Read.GenesisPoint
- (chain, tip) <- atomically $ do
- modifyTVar mfollowers (follower :)
- (,) <$> readTVar mchain <*> readTVar mtip
- case reverse chain of
- [] -> pure ()
- (b : bs) -> rollForward follower (b :| bs) tip
-
- let forgeBlock tx = atomically $ do
- tipOld <- readTVar mtip
- let txRead = Write.toConwayTx tx
- blockNew = Read.mockNextBlock tipOld [txRead]
- tipNew = Read.getChainPoint blockNew
- writeTVar mtip tipNew
- modifyTVar mchain (blockNew :)
- pure (blockNew, tipNew)
-
- let broadcast block tip = do
- followers <- readTVarIO mfollowers
- for_ followers $ \follower ->
- rollForward follower (block :| []) tip
-
- pure
- NetworkEnv
- { chainSync = \_ follower -> do
- registerAndUpdate follower
- forever $ threadDelay 1000000
- , postTx = \tx -> do
- (block, tip) <- forgeBlock tx
- broadcast block tip
- -- brief delay to account for asynchronous chain followers
- threadDelay 100
- pure $ Right ()
- , currentPParams =
- pure $ Read.EraValue Read.mockPParamsConway
- , getTimeTranslation =
- pure $ Time.toTimeTranslationPure Time.mockTimeInterpreter
- , slotToUTCTime = pure Time.unsafeUTCTimeOfSlot
- }
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/NodeToClient.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/NodeToClient.hs
deleted file mode 100644
index d6f8632980e..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/NodeToClient.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Real implementation of a 'NetworkEnv'.
-module Cardano.Wallet.Deposit.IO.Network.NodeToClient
- ( fromNetworkLayer
- , NetworkLayer
- , CardanoBlock
- , StandardCrypto
- ) where
-
-import Prelude
-
-import Cardano.Ledger.Api
- ( StandardCrypto
- )
-import Cardano.Wallet.Deposit.IO.Network.Type
- ( ErrPostTx (..)
- , NetworkEnv (..)
- , mapBlock
- )
-import Cardano.Wallet.Deposit.Time
- ( toTimeTranslation
- )
-import Cardano.Wallet.Network
- ( NetworkLayer
- , mapChainFollower
- )
-import Cardano.Wallet.Primitive.Ledger.Shelley
- ( CardanoBlock
- )
-import Cardano.Wallet.Primitive.Slotting
- ( snapshot
- )
-import Cardano.Wallet.Read
- ( chainPointFromChainTip
- )
-import Control.Monad.Trans.Except
- ( runExceptT
- , withExceptT
- )
-import Control.Tracer
- ( nullTracer
- )
-
-import qualified Cardano.Read.Ledger.Block.Block as Read
-import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Cardano.Wallet.Deposit.Time as Time
-import qualified Cardano.Wallet.Network as NetworkLayer
-
-{-----------------------------------------------------------------------------
- NodeToClient 'NetworkEnv'
-------------------------------------------------------------------------------}
-
--- | Translate the old NetworkLayer to the new NetworkEnv interface
-fromNetworkLayer
- :: NetworkLayer.NetworkLayer IO Read.ConsensusBlock
- -> NetworkEnv IO (Read.EraValue Read.Block)
-fromNetworkLayer nl = mapBlock Read.fromConsensusBlock $
- NetworkEnv
- { chainSync = \_tr follower -> do
- -- TODO: Connect tracer
- let follower' = mapChainFollower id id chainPointFromChainTip id follower
- NetworkLayer.chainSync nl nullTracer follower'
- return $ error "impossible: chainSync returned"
- -- TODO: We can change the error type of 'NetworkLayer.postTx' it
- -- doesn't need the ErrPostTxEraUnsupported case
- , postTx = runExceptT . withExceptT translateErrPostTx . NetworkLayer.postTx nl
- , currentPParams =
- NetworkLayer.currentPParams nl
- , getTimeTranslation = toTimeTranslation (NetworkLayer.timeInterpreter nl)
- , slotToUTCTime = Time.slotToUTCTime <$> snapshot ti
- }
-
- where
- ti = NetworkLayer.timeInterpreter nl
-
- translateErrPostTx :: NetworkLayer.ErrPostTx -> ErrPostTx
- translateErrPostTx = \case
- NetworkLayer.ErrPostTxValidationError errorText -> ErrPostTxValidationError errorText
- NetworkLayer.ErrPostTxMempoolFull -> ErrPostTxMempoolFull
- NetworkLayer.ErrPostTxEraUnsupported _era ->
- error "translateErrPostTx: ErrPostTxEraUnsupported should be impossible"
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs
deleted file mode 100644
index 8e3d92cff59..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs
+++ /dev/null
@@ -1,100 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
-module Cardano.Wallet.Deposit.IO.Network.Type
- ( NetworkEnv (..)
- , ErrPostTx (..)
- , mapBlock
- , ChainFollower (..)
- ) where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.Read
- ( Slot
- , WithOrigin
- )
-import Cardano.Wallet.Network
- ( ChainFollower (..)
- , mapChainFollower
- )
-import Control.Monad.Class.MonadTime
- ( UTCTime
- )
-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
-import qualified Cardano.Wallet.Deposit.Time as Time
-import qualified Cardano.Wallet.Deposit.Write as Write
-
-{-----------------------------------------------------------------------------
- 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
- :: Write.Tx
- -> m (Either ErrPostTx ())
- -- ^ Post a transaction to the Cardano network.
- , currentPParams
- :: m (Read.EraValue Read.PParams)
- -- ^ Current protocol paramters.
- , getTimeTranslation
- :: m Time.TimeTranslation
- -- ^ Get the current 'TimeInterpreter' from the Cardano node.
- , slotToUTCTime
- :: m (Slot -> (Maybe (WithOrigin UTCTime)))
-
- }
-
-mapBlock
- :: Functor m
- => (block1 -> block2)
- -> NetworkEnv m block1
- -> NetworkEnv m block2
-mapBlock f env@NetworkEnv{chainSync} = env
- { chainSync = \tr follower ->
- chainSync tr (mapChainFollower id id id (fmap f) follower)
- }
-
-{-------------------------------------------------------------------------------
- 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/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs
deleted file mode 100644
index 1f3168023b0..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs
+++ /dev/null
@@ -1,228 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Use void" #-}
-
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Implementation of a 'Resource' (think REST) which can be initialized.
-module Cardano.Wallet.Deposit.IO.Resource
- ( Resource
- , withResource
- , ErrResourceMissing (..)
- , onResource
- , ErrResourceExists (..)
- , putResource
- , ResourceStatus (..)
- , readStatus
- , closeResource
- ) where
-
-import Prelude
-
-import Control.Concurrent
- ( forkFinally
- )
-import Control.Concurrent.Class.MonadSTM
- ( MonadSTM (..)
- , TVar
- , atomically
- , readTVar
- , writeTVar
- )
-import Control.Monad
- ( void
- )
-import Control.Monad.Class.MonadThrow
- ( MonadThrow (..)
- , SomeException
- )
-
-{-----------------------------------------------------------------------------
- Resource
-------------------------------------------------------------------------------}
-
--- | Mutable resource (think REST) that holds a reference of type @a@
--- that has to be initialized with a 'with…' function.
-data Resource e a = Resource
- { content :: TVar IO (ResourceStatus e a)
- , waitForEndOfLife :: IO (Either (Either SomeException e) ())
- -- ^ Wait until the 'Resource' is out of scope.
- }
-
--- | Possible status of the content of a 'Resource'.
-data ResourceStatus e a
- = Closed
- | Opening
- | Open a
- | FailedToOpen e
- | Vanished SomeException
- | Closing
- deriving (Show)
-
-instance Functor (ResourceStatus e) where
- fmap _ Closed = Closed
- fmap _ Opening = Opening
- fmap f (Open a) = Open (f a)
- fmap _ (Vanished e) = Vanished e
- fmap _ (FailedToOpen e) = FailedToOpen e
- fmap _ Closing = Closing
-
--- | Read the status of a 'Resource'.
-readStatus :: Resource e a -> STM IO (ResourceStatus e a)
-readStatus resource = readTVar (content resource)
-
--- | Make a 'Resource' that can be initialized later.
---
--- Once the 'Resource' has been initialized,
--- it will also be cleaned up once the 'withResource' function has finished.
---
--- If the 'Resource' vanishes because of an exception,
--- the 'withResource' will /not/ be interrupted.
--- You can use 'getStatus' to poll the current status.
-withResource
- :: (Resource e a -> IO b)
- -- ^ Action to perform on the 'Resource'.
- -> IO b
- -- ^ Result of the action.
-withResource action = do
- content <- newTVarIO Closed
- let waitForEndOfLife = atomically $ do
- state <- readTVar content
- case state of
- Closing -> pure $ Right ()
- Vanished e -> pure $ Left $ Left e
- FailedToOpen e -> pure $ Left $ Right e
- _ -> retry
- resource = Resource{content, waitForEndOfLife}
- action resource `finally` closeResource resource
-
--- | Error condition for 'onResource'.
-data ErrResourceMissing e
- = -- | The 'Resource' has not been initialized yet.
- ErrNotInitialized
- | -- | The 'Resource' is currently being initialized.
- ErrStillInitializing
- | -- | The 'Resource' has not been initialized yet.
- ErrVanished SomeException
- | -- | The 'Resource' has vanished due to an unhandled exception.
- ErrFailedToInitialize e
- -- | The 'Resource' has failed to initialize.
- | ErrClosing
- -- | The 'Resource is currently being closed.
- deriving (Show)
-
--- | Perform an action on a 'Resource' if it is initialized.
-onResource
- :: (a -> IO b)
- -- ^ Action to perform on the initialized 'Resource'.
- -> Resource e a
- -- ^ The 'Resource' to act on.
- -> IO (Either (ErrResourceMissing e) b)
-onResource action resource = do
- eContent <- readTVarIO $ content resource
- case eContent of
- Closed -> pure $ Left ErrNotInitialized
- Opening -> pure $ Left ErrStillInitializing
- Open a -> Right <$> action a
- Vanished e -> pure $ Left $ ErrVanished e
- FailedToOpen e -> pure $ Left $ ErrFailedToInitialize e
- Closing -> pure $ Left ErrClosing
-
-closeResource :: Resource e a -> IO (Either (ErrResourceMissing e) ())
-closeResource resource = do
- r <- atomically $ do
- status <- readTVar $ content resource
- case status of
- Closed -> pure $ Right ()
- Opening -> pure $ Left ErrStillInitializing
- Open _ -> do
- writeTVar (content resource) Closing
- pure $ Right ()
- Vanished e -> pure $ Left $ ErrVanished e
- FailedToOpen e -> pure $ Left $ ErrFailedToInitialize e
- Closing -> pure $ Left ErrClosing
- case r of
- Right () -> waitForClose resource
- Left e' -> pure $ Left e'
-
-waitForClose :: Resource e a -> IO (Either (ErrResourceMissing e) ())
-waitForClose resource = do
- e <- atomically $ do
- status <- readTVar (content resource)
- case status of
- Closed -> pure $ Right ()
- Vanished e -> pure $ Left $ ErrVanished e
- FailedToOpen e -> pure $ Left $ ErrFailedToInitialize e
- _ -> retry
- case e of
- Right () -> pure $ Right ()
- Left e' -> pure $ Left e'
-
--- | Error condition for 'putResource'.
-data ErrResourceExists e a
- = -- | The resource 'a' is currently being initialized.
- ErrAlreadyInitializing
- | -- | The resource 'a' has already been initialized.
- ErrAlreadyInitialized a
- | -- | The resource 'a' has vanished.
- ErrAlreadyVanished SomeException
- | -- | The resource 'a' has failed to initialize.
- ErrAlreadyFailedToInitialize e
- | -- | The resource 'a' is currently being closed.
- ErrAlreadyClosing
- deriving (Show)
-
--- | Initialize a 'Resource' using a @with…@ function.
--- This @with…@ function will be called with an argument that does
--- not terminate until 'withResource' terminates.
--- The function can logically fail returning a 'Left' value.
--- Exceptions will be caught and stored in the 'Resource' as well
-putResource
- :: (forall b. (a -> IO b) -> IO (Either e b))
- -- ^ Function to initialize the resource 'a'
- -> Resource e a
- -- ^ The 'Resource' to initialize.
- -> IO (Either (ErrResourceExists e a) ())
-putResource start resource = do
- forking <- atomically $ do
- ca :: ResourceStatus e a <- readTVar (content resource)
- case ca of
- FailedToOpen e -> pure $ Left $ ErrAlreadyFailedToInitialize e
- Vanished e -> pure $ Left $ ErrAlreadyVanished e
- Opening -> pure $ Left ErrAlreadyInitializing
- Open a -> pure $ Left $ ErrAlreadyInitialized a
- Closed -> do
- writeTVar (content resource) Opening
- pure $ Right forkInitialization
- Closing -> pure $ Left ErrAlreadyClosing
- case forking of
- Left e -> pure $ Left e
- Right action -> Right <$> action
- where
- controlInitialization = do
- r <- start run
- atomically $ case r of
- Right (Right ()) -> do
- writeTVar (content resource) Closed
- Right (Left (Left e)) -> do
- writeTVar (content resource) (Vanished e)
- Right (Left (Right e)) -> do
- writeTVar (content resource) (FailedToOpen e)
- Left e -> do
- writeTVar (content resource) (FailedToOpen e)
-
- forkInitialization = void $ forkFinally controlInitialization vanish
-
- run a = do
- atomically $ writeTVar (content resource) (Open a)
- waitForEndOfLife resource
-
- vanish (Left e) = do
- atomically $ writeTVar (content resource) (Vanished e)
- vanish (Right _) =
- pure () -- waitForEndOfLife has succeeded
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource/Event.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource/Event.hs
deleted file mode 100644
index 0cdb58e3008..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource/Event.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-module Cardano.Wallet.Deposit.IO.Resource.Event
- ( onResourceChange
- ) where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.IO.Resource
- ( Resource
- , ResourceStatus (..)
- , readStatus
- )
-import Control.Concurrent.Async
- ( withAsync
- )
-import Control.Concurrent.Class.MonadSTM
- ( MonadSTM (..)
- , atomically
- )
-import Control.Monad
- ( void
- )
-import Control.Monad.Cont
- ( ContT (..)
- )
-import Control.Monad.Fix
- ( fix
- )
-
--- | Run an action whenever the status of a 'Resource' changes.
-onResourceChange
- :: (ResourceStatus e a -> IO ())
- -> Resource e a
- -> ContT x IO ()
-onResourceChange f resource = do
- void $ ContT $ withAsync $ ($ Closed) $ fix $ \loop lastStatus -> do
- status <- atomically $ do
- status <- readStatus resource
- case (status, lastStatus) of
- (Closed, Closed) -> retry
- (Opening, Opening) -> retry
- (Open _a, Open _a') -> retry -- this is something to think about
- (FailedToOpen _e, FailedToOpen _e') -> retry
- (Vanished _e, Vanished _e') -> retry
- (Closing, Closing) -> retry
- _ -> pure ()
- pure status
- f status
- loop status
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs
deleted file mode 100644
index 556e8354aec..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map.hs
+++ /dev/null
@@ -1,305 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE StrictData #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Cardano.Wallet.Deposit.Map
- ( -- * Type
- Map (..)
-
- -- * Keys
- , W
- , F
-
- -- * Patch management
- , unPatch
- , forgetPatch
-
- -- * Accessors
- , OpenF
- , open
- , PatchF
- , patch
- , ValueF
- , value
-
- -- * Lookup
- , lookupMap
- , lookupFinger
-
- -- * Construction
- , singletonMap
- , singletonFinger
-
- -- * Conversion
- , toFinger
-
- -- * Modification
- , onMap
- , onFinger
- , Peel
- )
-where
-
-import Cardano.Wallet.Deposit.Map.Timed
- ( Timed (..)
- , TimedSeq
- , extractInterval
- , fmapTimedSeq
- , singleton
- )
-import Data.Kind
- ( Type
- )
-import Data.Map.Monoidal.Strict
- ( MonoidalMap
- )
-import Data.Monoid
- ( Last (..)
- )
-import Prelude hiding
- ( lookup
- )
-
-import qualified Cardano.Wallet.Deposit.Map.Timed as TimedSeq
-import qualified Data.Map.Monoidal.Strict as MonoidalMap
-
--- | Infix form of MonoidalMap type
-type (^^^) = MonoidalMap
-
-infixr 5 ^^^
-
--- | A phantom type for tuples of mappings from 'k' tupled with a spurious monoid
--- 'w'. This is used to keep track of the patches applied to the map.
-data W (w :: Type) (k :: Type)
-
--- | A phantom type for a finger tree of mappings from 'k' tupled with a spurious
--- monoid 'w'.
-data F (w :: Type) (k :: Type)
-
--- | A nested monoidal map. Every nesting can also be patched with a monoid 'w'.
-data Map :: [Type] -> Type -> Type where
- Value
- :: v
- -> Map '[] v
- -- ^ A leaf node with a value.
- Map
- :: w
- -> k ^^^ Map ks v
- -> Map (W w k ': ks) v
- -- ^ A node with a patch 'w' and a nested monoidal map.
- Finger
- :: w
- -> TimedSeq k (Map ks v)
- -> Map (F w k ': ks) v
- -- ^ A node with a patch 'w' and a nested finger tree of maps.
-
-deriving instance Show v => Show (Map '[] v)
-
-deriving instance
- ( Show w
- , Show k
- , Show (Map ks v)
- )
- => Show (Map (W w k ': ks) v)
-
-deriving instance Eq v => Eq (Map '[] v)
-
-deriving instance
- ( Eq w
- , Eq k
- , Eq (Map ks v)
- )
- => Eq (Map (W w k ': ks) v)
-
-deriving instance
- ( Show w
- , Show k
- , Show (Map ks v)
- )
- => Show (Map (F w k ': ks) v)
-
-deriving instance
- ( Eq w
- , Eq k
- , Eq (Map ks v)
- )
- => Eq (Map (F w k ': ks) v)
-
-instance Functor (Map '[]) where
- fmap f (Value v) = Value (f v)
-
-instance Functor (Map xs) => Functor (Map (W w x : xs)) where
- fmap f (Map w m) = Map w $ fmap (fmap f) m
-
-instance
- (Functor (Map xs), forall a. Monoid (Map xs a))
- => Functor (Map (F w x : xs))
- where
- fmap f (Finger w m) = Finger w $ fmapTimedSeq (fmap f) m
-
-instance Monoid v => Monoid (Map '[] v) where
- mempty = Value mempty
-
-instance
- ( Monoid (Map ks v)
- , Ord k
- , Monoid w
- )
- => Monoid (Map (W w k : ks) v)
- where
- mempty = Map mempty mempty
-
-instance (Monoid (Map xs v), Monoid w, Eq x) => Monoid (Map (F w x : xs) v) where
- mempty = Finger mempty mempty
-
-instance Semigroup v => Semigroup (Map '[] v) where
- Value a <> Value b = Value (a <> b)
-
-instance
- ( Ord x
- , Semigroup (Map xs v)
- , Semigroup w
- )
- => Semigroup (Map (W w x : xs) v)
- where
- Map w a <> Map w' b = Map (w <> w') (a <> b)
-
-instance
- (Monoid w, Monoid (Map xs v), Eq x)
- => Semigroup (Map (F w x : xs) v)
- where
- Finger wa a <> Finger wb b = Finger (wa <> wb) (a <> b)
-
-instance Foldable (Map '[]) where
- foldMap f (Value v) = f v
-
-instance (Foldable (Map xs), Ord x) => Foldable (Map (F w x : xs)) where
- foldMap f (Finger _ m) = foldMap (foldMap f) m
-
-instance (Foldable (Map xs), Ord x) => Foldable (Map (W w x : xs)) where
- foldMap f (Map _ m) = foldMap (foldMap f) m
-
-type family UnPatchF xs where
- UnPatchF (Map (W w x ': xs) v) =
- Map (W () x ': xs) (w, v)
- UnPatchF (Map (F w x ': xs) v) =
- Map (F () x ': xs) (w, v)
-
--- | Push the patch down to the leaves of the map.
-unPatch
- :: ( y ~ Map (x : ks) v
- , Functor (Map ks)
- , Monoid (Map ks v)
- , Monoid (Map ks (w, v))
- , w ~ PatchF x
- )
- => y
- -> UnPatchF y
-unPatch (Map w m) = Map () $ fmap (fmap (w,)) m
-unPatch (Finger w m) = Finger () $ fmapTimedSeq (fmap (w,)) m
-
-type family ForgetPatchF xs where
- ForgetPatchF (Map (W w x ': xs) v) =
- Map (W () x ': xs) v
- ForgetPatchF (Map (F w x ': xs) v) =
- Map (F () x ': xs) v
-
--- | Forget the patch of any map layer.
-forgetPatch
- :: (y ~ Map (x : ks) v)
- => y
- -> ForgetPatchF y
-forgetPatch ((Map _ m)) = Map () m
-forgetPatch ((Finger _ m)) = Finger () m
-
-type family PatchF x where
- PatchF (W w x) = w
- PatchF (F w x) = w
-
--- | Extract the patch from any map layer.
-patch :: Map (x : xs) v -> PatchF x
-patch (Map w _) = w
-patch (Finger w _) = w
-
-type family ValueF x where
- ValueF (Map '[] v) = v
- ValueF (Map (W w x ': xs) v) = x ^^^ Map xs v
- ValueF (Map (F w x ': xs) v) = TimedSeq x (Map xs v)
-
--- | Extract the value from any map layer.
-value :: Map xs v -> ValueF (Map xs v)
-value (Map _ m) = m
-value (Finger _ m) = m
-value (Value v) = v
-
-type family OpenF xs where
- OpenF (Map (W w x ': xs) v) = (w, x ^^^ Map xs v)
- OpenF (Map (F w x ': xs) v) = (w, TimedSeq x (Map xs v))
-
--- | Open any map layer and return the patch as well.
-open :: Map (x : xs) v -> OpenF (Map (x : xs) v)
-open (Map w m) = (w, m)
-open (Finger w m) = (w, m)
-
--- | Construct a map layer with a single key-value pair.
-singletonMap
- :: w -> k -> Map xs v -> Map (W w k ': xs) v
-singletonMap w k = Map w . MonoidalMap.singleton k
-
--- | Construct a finger layer with a single key-value pair.
-singletonFinger
- :: Monoid (Map xs v) => w -> k -> Map xs v -> Map (F w k ': xs) v
-singletonFinger w k m =
- Finger w $ singleton $ Timed (Last (Just k)) m
-
-toFinger
- :: (Monoid (Map ks a), Eq k) => Map (W w k : ks) a -> Map (F w k : ks) a
-toFinger (Map w m) = Finger w $ TimedSeq.fromList $ do
- (k, v) <- MonoidalMap.toList m
- pure $ Timed (Last (Just k)) v
-
--- | Lookup a value in first layer of the map and return the patch as well.
-lookupMap
- :: (Ord k) => k -> Map (W w k : ks) a -> Maybe (w, Map ks a)
-lookupMap k (Map w m) = (w,) <$> MonoidalMap.lookup k m
-
--- | Lookup for an interval of keys in the finger tree and return the patch as well.
-lookupFinger
- :: (Ord k, Monoid (Map ks a))
- => k
- -> k
- -> Map (F w k : ks) a
- -> Maybe (w, Map ks a)
-lookupFinger k1 k2 (Finger w m) = do
- case extractInterval k1 k2 m of
- Timed (Last Nothing) _ -> Nothing
- Timed _ m' -> Just (w, m')
-
--- | Apply a function to the nested monoidal map keeping the patch.
-onMap
- :: Map (W w k : ks) a
- -> (MonoidalMap k (Map ks a) -> MonoidalMap k (Map ks a))
- -> Map (W w k : ks) a
-onMap (Map w m) f = Map w $ f m
-
--- | Apply a function to the nested finger tree keeping the patch.
-onFinger
- :: Map (F w k : ks) a
- -> (TimedSeq k (Map ks a) -> TimedSeq k (Map ks a))
- -> Map (F w k : ks) a
-onFinger (Finger w m) f = Finger w $ f m
-
-type family Peel x where
- Peel (Map (W w k : xs) v) = Map xs v
- Peel (Map (F w k : xs) v) = Map xs v
- Peel (Map '[] v) = v
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs
deleted file mode 100644
index d8e5efc8082..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Map/Timed.hs
+++ /dev/null
@@ -1,265 +0,0 @@
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module Cardano.Wallet.Deposit.Map.Timed
- (
- -- * Timed
- Timed (..)
- -- * TimedSeq
- , TimedSeq
- -- ** Construction
- , fromList
- , singleton
- -- ** Destruction
- , toList
- -- ** Query
- , takeAfter
- , takeUpTo
- , extractInterval
- , minKey
- , maxKey
- -- ** Modification
- , dropAfter
- , dropBefore
- -- ** Functor
- , fmapTimedSeq
- )
-where
-
-import Prelude hiding
- ( null
- )
-
-import Data.Bifunctor
- ( Bifunctor (..)
- )
-import Data.FingerTree
- ( FingerTree
- , Measured (..)
- , ViewL (..)
- , ViewR (..)
- , dropUntil
- , fmap'
- , split
- , takeUntil
- , viewl
- , viewr
- , (<|)
- )
-import Data.Function
- ( (&)
- )
-import Data.Monoid
- ( Last (..)
- )
-
-import qualified Data.FingerTree as FingerTree
-import qualified Data.Foldable as F
-
--- | A value paired with a timestamp.
-data Timed t a = Timed
- { time :: Last t
- , monoid :: a
- }
- deriving (Eq, Ord, Show, Functor, Foldable)
-
-instance Semigroup a => Semigroup (Timed t a) where
- Timed t1 a1 <> Timed t2 a2 = Timed (t1 <> t2) (a1 <> a2)
-
-instance Monoid a => Monoid (Timed t a) where
- mempty = Timed mempty mempty
-
-instance Monoid a => Measured (Timed t a) (Timed t a) where
- measure = id
-
--- | A sequence of timed values with a monoidal annotation as itself.
--- These values have a semigroup instance that will collapse adjacent values
--- with the same timestamp.
--- It's up to the user to maintain the invariant that
--- the sequence is sorted by timestamp.
-newtype TimedSeq t a = TimedSeq
- { unTimedSeq :: FingerTree (Timed t a) (Timed t a)
- }
- deriving (Eq, Show)
-
-fmapTimedSeq
- :: (Monoid a1, Monoid a2) => (a1 -> a2) -> TimedSeq t a1 -> TimedSeq t a2
-fmapTimedSeq f = TimedSeq . fmap' (fmap f) . unTimedSeq
-
-singleton :: Monoid a => Timed t a -> TimedSeq t a
-singleton = TimedSeq . FingerTree.singleton
-
-instance Monoid a => Measured (Timed t a) (TimedSeq t a) where
- measure = measure . unTimedSeq
-
-instance Foldable (TimedSeq t) where
- foldMap f = foldMap (f . monoid) . unTimedSeq
-
-onFingerTree
- :: ( FingerTree (Timed t a) (Timed t a)
- -> FingerTree (Timed t a) (Timed t a)
- )
- -> TimedSeq t a
- -> TimedSeq t a
-onFingerTree f = TimedSeq . f . unTimedSeq
-
-instance (Semigroup a, Monoid a, Eq t) => Semigroup (TimedSeq t a) where
- TimedSeq a <> TimedSeq b = case (viewr a, viewl b) of
- (EmptyR, _) -> TimedSeq b
- (_, EmptyL) -> TimedSeq a
- (a' :> Timed t1 v1, Timed t2 v2 :< b')
- | t1 == t2 -> TimedSeq $ a' <> (Timed t1 (v1 <> v2) <| b')
- | otherwise -> TimedSeq $ a <> b
-
-instance (Monoid a, Eq t) => Monoid (TimedSeq t a) where
- mempty = TimedSeq FingerTree.empty
-
--- | Construct a 'TimedSeq' from a list of 'Timed' values.
-fromList :: (Monoid a, Eq t) => [Timed t a] -> TimedSeq t a
-fromList = mconcat . fmap singleton
-
--- | Convert a 'TimedSeq' to a list of 'Timed' values.
--- This is not the inverse of 'fromList' as some values may have been merged. But
--- fromList . toList == id.
-toList :: TimedSeq t a -> [Timed t a]
-toList = F.toList . unTimedSeq
-
-takeAfterElement
- :: (Monoid a, Ord q)
- => (t -> q)
- -> TimedSeq t a
- -> Maybe (Timed t a, TimedSeq t a)
-takeAfterElement bucket (TimedSeq tseq) = case viewl tseq of
- EmptyL -> Nothing
- hd :< _ ->
- let
- (taken, rest) =
- split (\q -> (bucket <$> time q) > (bucket <$> time hd)) tseq
- in
- Just (measure taken, TimedSeq rest)
-
-takeBeforeElement
- :: (Monoid a, Ord q)
- => (t -> q)
- -> TimedSeq t a
- -> Maybe (Timed t a, TimedSeq t a)
-takeBeforeElement bucket (TimedSeq tseq) = case viewr tseq of
- EmptyR -> Nothing
- _ :> hd ->
- let
- (rest, taken) =
- split (\q -> (bucket <$> time q) >= (bucket <$> time hd)) tseq
- in
- Just (measure taken, TimedSeq rest)
-
-takeAfterElements
- :: (Monoid a, Ord q, Ord t)
- => (t -> q)
- -> Maybe Int
- -> TimedSeq t a
- -> (TimedSeq t a, Maybe t)
-takeAfterElements _dt (Just 0) (TimedSeq tseq) =
- ( mempty
- , case viewl tseq of
- EmptyL -> Nothing
- Timed (Last hd) _ :< _ -> hd
- )
-takeAfterElements bucket mn tseq =
- case takeAfterElement bucket tseq of
- Just (v, rest) ->
- first (onFingerTree (v <|))
- $ takeAfterElements bucket (subtract 1 <$> mn) rest
- _ -> (mempty, Nothing)
-
-takeBeforeElements
- :: (Monoid a, Ord q, Ord t)
- => (t -> q)
- -> Maybe Int
- -> TimedSeq t a
- -> (TimedSeq t a, Maybe t)
-takeBeforeElements _dt (Just 0) (TimedSeq tseq) =
- ( mempty
- , case viewr tseq of
- EmptyR -> Nothing
- _ :> Timed (Last hd) _ -> hd
- )
-takeBeforeElements bucket mn tseq = case takeBeforeElement bucket tseq of
- Just (v, rest) ->
- first (onFingerTree (v <|))
- $ takeBeforeElements bucket (subtract 1 <$> mn) rest
- _ -> (mempty, Nothing)
-
--- | Extract the first n elements from a timed seq after and including
--- a given start time after applying a bucketing function.
--- The result is a map of the extracted elements and the next time to start from.
-takeAfter
- :: (Monoid a, Ord q, Ord t)
- => (t -> q)
- -- ^ A function to bucket the timestamps.
- -> Maybe t
- -- ^ The start time to extract elements from.
- -> Maybe Int
- -- ^ The number of elements to extract.
- -> TimedSeq t a
- -- ^ The timed sequence to extract elements from.
- -> (TimedSeq t a, Maybe t)
-takeAfter bucket mstart mcount =
- takeAfterElements bucket mcount
- . onFingerTree
- ( dropUntil
- ( \q -> mstart & maybe True (\t -> time q >= Last (Just t))
- )
- )
-
--- | Extract the last n elements from a timed seq before and excluding
--- a given start time after applying a bucketing function.
--- The result is a map of the extracted elements and the next time to start from.
-takeUpTo
- :: (Monoid a, Ord q, Ord t)
- => (t -> q)
- -- ^ A function to bucket the timestamps.
- -> Maybe t
- -- ^ The start time to extract elements from.
- -> Maybe Int
- -- ^ The number of elements to extract.
- -> TimedSeq t a
- -- ^ The timed sequence to extract elements from.
- -> (TimedSeq t a, Maybe t)
-takeUpTo bucket mstart mcount =
- takeBeforeElements bucket mcount
- . onFingerTree
- ( takeUntil
- (\q -> mstart & maybe False (\t -> time q > Last (Just t)))
- )
-
--- | Try to extract the first element time from a tseq.
-minKey :: Monoid a => TimedSeq t a -> Maybe t
-minKey (TimedSeq tseq) = case viewl tseq of
- Timed (Last (Just t)) _ :< _ -> Just t
- _ -> Nothing
-
--- | Try to extract the last element time from a tseq.
-maxKey :: Monoid a => TimedSeq t a -> Maybe t
-maxKey (TimedSeq tseq) = case viewr tseq of
- _ :> Timed (Last (Just t)) _ -> Just t
- _ -> Nothing
-
--- | Extract all elements from a tseq that are within the given time interval.
-extractInterval
- :: (Monoid a, Ord t) => t -> t -> TimedSeq t a -> Timed t a
-extractInterval t0 t1 (TimedSeq tseq) =
- measure
- $ takeUntil (\q -> time q > Last (Just t1))
- $ dropUntil (\q -> time q >= Last (Just t0)) tseq
-
--- | Drop all elements from a tseq that are after the given time.
-dropAfter :: (Ord t, Monoid a) => t -> TimedSeq t a -> TimedSeq t a
-dropAfter t = onFingerTree $ takeUntil (\q -> time q > Last (Just t))
-
--- | Drop all elements from a tseq that are before the given time.
-dropBefore :: (Ord t, Monoid a) => t -> TimedSeq t a -> TimedSeq t a
-dropBefore t = onFingerTree $ dropUntil (\q -> time q >= Last (Just t))
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs
deleted file mode 100644
index 6de8e6a07e3..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs
+++ /dev/null
@@ -1,138 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Cardano.Wallet.Deposit.Pure
- ( -- * Types
- WalletState
- , DeltaWalletState
- , WalletPublicIdentity (..)
-
- -- * Creation
- , Credentials (..)
- , fromCredentialsAndGenesis
-
- -- * Operations
-
- -- ** Mapping between customers and addresses
- , Customer
- , listCustomers
- , addressToCustomer
- , deriveAddress
- , knownCustomer
- , knownCustomerAddress
- , isCustomerAddress
- , fromRawCustomer
- , customerAddress
- , trackedCustomers
- , walletXPub
-
- -- ** Reading from the blockchain
- , Word31
- , getWalletTip
- , availableBalance
- , availableUTxO
- , rollForwardMany
- , rollForwardOne
- , rollBackward
- , ValueTransfer (..)
- , getTxHistoryByCustomer
- , getTxHistoryByTime
- , getEraSlotOfBlock
- , getCustomerDeposits
- , getAllDeposits
- , networkTag
-
- -- ** Writing to the blockchain
- , ErrCreatePayment (..)
- , createPayment
- , resolveCurrentEraTx
- , CurrentEraResolvedTx
- , BIP32Path (..)
- , DerivationType (..)
- , ResolvedTx (..)
- , canSign
- , CanSign (..)
- , getBIP32PathsForOwnedInputs
- , Passphrase
- , signTx
- , addTxSubmission
- , listTxsInSubmission
- , inspectTx
- , InspectTx (..)
- ) where
-
-import Cardano.Wallet.Address.BIP32
- ( BIP32Path (..)
- , DerivationType (..)
- )
-import Cardano.Wallet.Deposit.Pure.State.Creation
- ( CanSign (..)
- , Credentials (..)
- , WalletPublicIdentity (..)
- , canSign
- , fromCredentialsAndGenesis
- )
-import Cardano.Wallet.Deposit.Pure.State.Payment
- ( CurrentEraResolvedTx
- , ErrCreatePayment (..)
- , createPayment
- , resolveCurrentEraTx
- )
-import Cardano.Wallet.Deposit.Pure.State.Payment.Inspect
- ( InspectTx (..)
- , inspectTx
- )
-import Cardano.Wallet.Deposit.Pure.State.Rolling
- ( rollBackward
- , rollForwardMany
- , rollForwardOne
- )
-import Cardano.Wallet.Deposit.Pure.State.Signing
- ( Passphrase
- , getBIP32PathsForOwnedInputs
- , signTx
- )
-import Cardano.Wallet.Deposit.Pure.State.Submissions
- ( addTxSubmission
- , availableBalance
- , availableUTxO
- , listTxsInSubmission
- )
-import Cardano.Wallet.Deposit.Pure.State.TxHistory
- ( getAllDeposits
- , getCustomerDeposits
- , getTxHistoryByCustomer
- , getTxHistoryByTime
- )
-import Cardano.Wallet.Deposit.Pure.State.Type
- ( Customer
- , DeltaWalletState
- , WalletState
- , addressToCustomer
- , customerAddress
- , deriveAddress
- , fromRawCustomer
- , getWalletTip
- , isCustomerAddress
- , knownCustomer
- , knownCustomerAddress
- , listCustomers
- , networkTag
- , trackedCustomers
- , walletXPub
- )
-import Cardano.Wallet.Deposit.Pure.UTxO.Tx
- ( ResolvedTx (..)
- )
-import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer
- ( ValueTransfer (..)
- )
-import Cardano.Wallet.Deposit.Read
- ( getEraSlotOfBlock
- )
-import Data.Word.Odd
- ( Word31
- )
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs
deleted file mode 100644
index 70c5785db3a..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/Address.hs
+++ /dev/null
@@ -1,210 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module Cardano.Wallet.Deposit.Pure.API.Address
- ( encodeAddress
- , decodeAddress
- , DecodingError (..)
- , NetworkTag (..)
- , getNetworkTag
- )
-where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.Read
- ( Address
- , NetworkTag (..)
- )
-import Cardano.Wallet.Primitive.Ledger.Shelley
- ( StandardCrypto
- )
-import Cardano.Wallet.Read.Address
- ( toShortByteString
- )
-import Codec.Binary.Bech32
- ( DataPart
- , HumanReadablePart
- , dataPartFromBytes
- , dataPartToBytes
- , decodeLenient
- )
-import Control.Arrow
- ( ArrowChoice (..)
- )
-import Control.Monad
- ( (>=>)
- )
-import Control.Monad.State.Strict
- ( evalStateT
- )
-import Data.ByteString
- ( ByteString
- )
-import Data.ByteString.Base58
- ( bitcoinAlphabet
- , decodeBase58
- , encodeBase58
- )
-import Data.Text
- ( Text
- )
-
-import qualified Cardano.Ledger.Address as SH
-import qualified Cardano.Ledger.Address as SL
-import qualified Cardano.Ledger.BaseTypes as SL
-import qualified Codec.Binary.Bech32 as Bech32
-import qualified Codec.Binary.Bech32.TH as Bech32
-import qualified Data.ByteString.Short as B8
-import qualified Data.Text.Encoding as T
-
-data AddressFlavor a b
- = Bootstrap
- {bootstrapFlavor :: a}
- | Shelley
- {shelleyFlavor :: b}
- deriving (Eq, Show)
-
-withAddressFlavor
- :: (a -> c)
- -> (b -> c)
- -> AddressFlavor a b
- -> c
-withAddressFlavor f _ (Bootstrap x) = f x
-withAddressFlavor _ g (Shelley x) = g x
-
--- | Errors that can occur when decoding an 'Address'.
-data DecodingError
- = InvalidBech32Encoding Bech32.DecodingError
- | InvalidBase58Encoding
- | InvalidHumanReadablePart HumanReadablePart
- | InvalidDataPart DataPart
- | AddressFlavorMismatch
- | AddressDecodingError String
- | AddressNetworkMismatch
- deriving (Eq, Show)
-
-humanPart :: NetworkTag -> HumanReadablePart
-humanPart = \case
- MainnetTag -> [Bech32.humanReadablePart|addr|]
- TestnetTag -> [Bech32.humanReadablePart|addr_test|]
-
-decodeBase58Address
- :: ByteString
- -> Either
- DecodingError
- ( AddressFlavor
- ByteString
- (ByteString, HumanReadablePart)
- )
-decodeBase58Address =
- fmap Bootstrap
- . maybe (Left InvalidBase58Encoding) Right
- . decodeBase58 bitcoinAlphabet
-
-decodeBech32Address
- :: Text
- -> Either
- DecodingError
- (AddressFlavor ByteString (ByteString, HumanReadablePart))
-decodeBech32Address bech32 = do
- (hrp, dataPart) <- left InvalidBech32Encoding $ decodeLenient bech32
- case dataPartToBytes dataPart of
- Nothing -> Left $ InvalidDataPart dataPart
- Just bytes -> pure $ Shelley (bytes, hrp)
-
-decodeHumanAddress
- :: Text
- -> Either
- DecodingError
- (AddressFlavor ByteString (ByteString, HumanReadablePart))
-decodeHumanAddress t =
- decodeBech32Address t
- <> decodeBase58Address (T.encodeUtf8 t)
-
-newtype CatchFail a = CatchFail {runCatchFail :: Either String a}
- deriving (Functor, Applicative, Monad)
-
-instance MonadFail CatchFail where
- fail = CatchFail . Left
-
-ledgerAddressFlavor :: SL.Addr c -> AddressFlavor () ()
-ledgerAddressFlavor (SL.AddrBootstrap _) = Bootstrap ()
-ledgerAddressFlavor _ = Shelley ()
-
-ledgerAddressNetworkTag :: SL.Addr c -> NetworkTag
-ledgerAddressNetworkTag addr = case SL.getNetwork addr of
- SL.Testnet -> TestnetTag
- SL.Mainnet -> MainnetTag
-
--- | Get the network tag of an 'Address'.
-getNetworkTag :: Address -> NetworkTag
-getNetworkTag = ledgerAddressNetworkTag . SL.decompactAddr
-
-ledgerDecode
- :: ByteString
- -> Either DecodingError (SL.Addr StandardCrypto)
-ledgerDecode bs =
- left AddressDecodingError
- $ runCatchFail
- $ evalStateT
- (SH.decodeAddrStateLenientT @StandardCrypto True True bs)
- 0
-
-inspectAddress
- :: AddressFlavor ByteString (ByteString, HumanReadablePart)
- -> Either DecodingError (AddressFlavor Address Address)
-inspectAddress (Bootstrap a) = do
- r <- ledgerDecode a
- case ledgerAddressFlavor r of
- Bootstrap () ->
- pure (Bootstrap $ SH.compactAddr r)
- _ -> Left AddressFlavorMismatch
-inspectAddress (Shelley (bytes, hrp)) = do
- r <- ledgerDecode bytes
- case (ledgerAddressNetworkTag r, ledgerAddressFlavor r) of
- (network, Shelley ()) ->
- if humanPart network == hrp
- then pure (Shelley $ SH.compactAddr r)
- else Left AddressNetworkMismatch
- _ -> Left AddressFlavorMismatch
-
-decodeFlavoredAddress
- :: Text
- -> Either DecodingError (AddressFlavor Address Address)
-decodeFlavoredAddress = decodeHumanAddress >=> inspectAddress
-
--- | Decode an 'Address' from a 'Text' representation.
-decodeAddress
- :: Text
- -- ^ Text to decode
- -> Either DecodingError Address
-decodeAddress text = withAddressFlavor id id <$> decodeFlavoredAddress text
-
-addFlavorToAddress :: Address -> AddressFlavor Address Address
-addFlavorToAddress x
- | SL.isBootstrapCompactAddr x = Bootstrap x
- | otherwise = Shelley x
-
-encodeFlavoredAddress
- :: AddressFlavor Address Address
- -> Text
-encodeFlavoredAddress (Shelley addr) = bech32
- where
- bytes = B8.fromShort $ toShortByteString addr
- bech32 = Bech32.encodeLenient hrp (dataPartFromBytes bytes)
- hrp = humanPart $ getNetworkTag addr
-encodeFlavoredAddress (Bootstrap addr) =
- T.decodeUtf8 . encodeBase58 bitcoinAlphabet
- $ B8.fromShort
- $ toShortByteString addr
-
--- | Encode an 'Address' to a 'Text' representation.
-encodeAddress
- :: Address
- -- ^ Address to encode
- -> Text
-encodeAddress = encodeFlavoredAddress . addFlavorToAddress
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory.hs
deleted file mode 100644
index c01d7159b0c..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/API/TxHistory.hs
+++ /dev/null
@@ -1,168 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE StrictData #-}
-
-module Cardano.Wallet.Deposit.Pure.API.TxHistory
- ( ByCustomer
- , ByTime
- , DownTime
- , ResolveAddress
- , LookupTimeFromSlot
- , TxHistory (..)
- , firstJust
- , transfers
- , rollForward
- , rollBackward
- )
-where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.Map
- ( F
- , Map (..)
- , W
- , onFinger
- , onMap
- , singletonFinger
- , singletonMap
- )
-import Cardano.Wallet.Deposit.Map.Timed
- ( TimedSeq
- , dropBefore
- )
-import Cardano.Wallet.Deposit.Pure.Address
- ( Customer
- )
-import Cardano.Wallet.Deposit.Pure.Balance
- ( ValueTransferMap
- )
-import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer
- ( ValueTransfer
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- , WithOrigin (..)
- )
-import Cardano.Wallet.Deposit.Time
- ( LookupTimeFromSlot
- )
-import Cardano.Wallet.Read
- ( Slot
- , TxId
- )
-import Data.Foldable
- ( Foldable (..)
- )
-import Data.Maybe
- ( maybeToList
- )
-import Data.Monoid
- ( First (..)
- )
-import Data.Ord
- ( Down (..)
- )
-import Data.Time
- ( UTCTime
- )
-
-import qualified Data.Map.Monoidal.Strict as MonoidalMap
-
-firstJust :: a -> First a
-firstJust = First . Just
-
-transfers
- :: Foldable (Map xs) => Map xs ValueTransfer -> ValueTransfer
-transfers = fold
-
-type DownTime = Down (WithOrigin UTCTime)
-
-type ByCustomer =
- Map
- '[ W () Customer
- , F (First Address) DownTime
- , W (First Slot) TxId
- ]
- ValueTransfer
-
-type ByTime =
- Map
- '[ F () DownTime
- , W (First Slot) Customer
- , W (First Address) TxId
- ]
- ValueTransfer
-
-data TxHistory = TxHistory
- { byCustomer :: ByCustomer
- , byTime :: ByTime
- }
-
-instance Semigroup TxHistory where
- TxHistory a1 b1 <> TxHistory a2 b2 = TxHistory (a1 <> a2) (b1 <> b2)
-
-instance Monoid TxHistory where
- mempty = TxHistory mempty mempty
-
-type ResolveAddress = Address -> Maybe Customer
-
-rollForward
- :: ValueTransferMap
- -> ResolveAddress
- -> LookupTimeFromSlot
- -> Slot
- -> TxHistory
- -> TxHistory
-rollForward valueTransferMap resolveAddress timeFromSlot slot =
- (txHistory' <>)
- where
- txHistory' =
- blockToTxHistory valueTransferMap resolveAddress timeFromSlot slot
-
-blockToTxHistory
- :: ValueTransferMap
- -> ResolveAddress
- -> LookupTimeFromSlot
- -> Slot
- -> TxHistory
-blockToTxHistory valueTransferMap resolveAddress timeFromSlot slot =
- fold $ do
- time <- fmap Down $ maybeToList $ timeFromSlot slot
- (address, valueTransferByTxId) <- MonoidalMap.toList valueTransferMap
- (txId, valueTransfer) <- MonoidalMap.toList valueTransferByTxId
- customer <- maybeToList $ resolveAddress address
- let byTime =
- singletonFinger () time
- $ singletonMap (First $ Just slot) customer
- $ singletonMap (First $ Just address) txId
- $ Value valueTransfer
- let byCustomer =
- singletonMap () customer
- $ singletonFinger (First $ Just address) time
- $ singletonMap (First $ Just slot) txId
- $ Value valueTransfer
- pure $ TxHistory{byCustomer, byTime}
-
--- | Roll backward the transaction history to a given slot. This function
--- relies on the TxHistory to be sorted by time both on the time and
--- customer views.
-rollBackward
- :: LookupTimeFromSlot
- -> Slot
- -> TxHistory
- -> TxHistory
-rollBackward timeFromSlot slot TxHistory{byCustomer, byTime} =
- TxHistory
- { byCustomer =
- onMap byCustomer
- $ cleanNulls . fmap (`onFinger` takeToSlot)
- , byTime = onFinger byTime takeToSlot
- }
- where
- takeToSlot :: Monoid a => TimedSeq DownTime a -> TimedSeq DownTime a
- takeToSlot x = maybe x (`forgetAfter` x) $ timeFromSlot slot
- forgetAfter t = dropBefore (Down t)
- cleanNulls = MonoidalMap.filter (not . null)
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs
deleted file mode 100644
index 35d56e49140..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Balance.hs
+++ /dev/null
@@ -1,131 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
--- | Wallet balance.
-module Cardano.Wallet.Deposit.Pure.Balance
- ( balance
- , availableUTxO
- , IsOurs
- , applyBlock
- , ValueTransferMap
- ) where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.Pure.UTxO.DeltaUTxO
- ( DeltaUTxO
- )
-import Cardano.Wallet.Deposit.Pure.UTxO.Tx
- ( IsOurs
- , applyTx
- , valueTransferFromDeltaUTxO
- )
-import Cardano.Wallet.Deposit.Pure.UTxO.UTxO
- ( UTxO
- , balance
- , excluding
- )
-import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer
- ( ValueTransfer
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- , TxId
- )
-import Cardano.Wallet.Read
- ( Block
- , IsEra
- , getTxId
- )
-import Data.Foldable
- ( Foldable (..)
- )
-import Data.Map.Monoidal.Strict
- ( MonoidalMap
- )
-import Data.Set
- ( Set
- )
-
-import qualified Cardano.Wallet.Deposit.Pure.UTxO.DeltaUTxO as DeltaUTxO
-import qualified Cardano.Wallet.Deposit.Write as Write
-import qualified Cardano.Wallet.Read as Read
-import qualified Data.Map.Monoidal.Strict as MonoidalMap
-import qualified Data.Map.Strict as Map
-
-{-----------------------------------------------------------------------------
- Wallet Balance
-------------------------------------------------------------------------------}
-
--- | Available = excluding pending transactions
-availableUTxO :: UTxO -> [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 :: Read.Tx Read.Conway -> Set Read.TxIn
- getUsedTxIn tx =
- Read.getInputs tx
- <> Read.getCollateralInputs tx
-
-{-----------------------------------------------------------------------------
- Applying Blocks
-------------------------------------------------------------------------------}
-
--- | Get the value transfer of a 'DeltaUTxO'.
-getDeltaUTxOValueTransfer
- :: UTxO
- -> DeltaUTxO
- -> TxId
- -> ValueTransferMap
-getDeltaUTxOValueTransfer u du txId = fold $ do
- (addr, value) <- Map.assocs $ valueTransferFromDeltaUTxO u du
- pure
- $ MonoidalMap.singleton addr
- $ MonoidalMap.singleton
- txId
- value
-
--- | A summary of all value transfers in a block.
-type ValueTransferMap =
- MonoidalMap Address (MonoidalMap TxId ValueTransfer)
-
--- | Apply a 'Block' to the 'UTxO'.
---
--- Returns both a delta and the new value.
-applyBlock
- :: IsEra era
- => IsOurs Read.CompactAddr
- -> Block era
- -> UTxO
- -> (DeltaUTxO, UTxO, ValueTransferMap)
-applyBlock isOurs block u0 =
- (DeltaUTxO.appends $ reverse dus, u1, totalValueTransfer)
- where
- (dus, (u1, totalValueTransfer)) =
- mapAccumL' applyTx' (u0, mempty)
- $ Read.getEraTransactions block
- applyTx' tx (u, total) =
- let
- (ds, u') = applyTx isOurs tx u
- value = getDeltaUTxOValueTransfer u ds (getTxId tx)
- total'
- | null value = total
- | otherwise = total <> value
- in
- (ds, (u', total'))
-
-{-----------------------------------------------------------------------------
- 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/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Creation.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Creation.hs
deleted file mode 100644
index 4ca891c21f8..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Creation.hs
+++ /dev/null
@@ -1,196 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module Cardano.Wallet.Deposit.Pure.State.Creation
- ( WalletPublicIdentity (..)
- , fromCredentialsAndGenesis
- , deriveAccountXPrv
- , Credentials (..)
- , credentialsFromMnemonics
- , credentialsFromEncodedXPub
- , accountXPubFromCredentials
- , rootXPrvFromCredentials
- , ErrDecodingXPub (..)
- , encodedXPubFromCredentials
- , canSign
- , CanSign (..)
- , createMnemonicFromWords
- ) where
-
-import Prelude hiding
- ( lookup
- )
-
-import Cardano.Address.Derivation
- ( xpubFromBytes
- , xpubToBytes
- )
-import Cardano.Address.Style.Shelley
- ( genMasterKeyFromMnemonicShelley
- )
-import Cardano.Mnemonic
- ( MkSomeMnemonic (..)
- , MkSomeMnemonicError
- , SomeMnemonic
- )
-import Cardano.Wallet.Address.BIP32_Ed25519
- ( XPrv
- , XPub
- , deriveXPrvHard
- , rawSerialiseXPrv
- , toXPub
- )
-import Cardano.Wallet.Deposit.Pure.State.Type
- ( WalletState (..)
- )
-import Data.Text
- ( Text
- )
-import Data.Word.Odd
- ( Word31
- )
-import GHC.Generics
- ( Generic
- )
-
-import Cardano.Crypto.Wallet
- ( xPrvChangePass
- )
-import qualified Cardano.Wallet.Deposit.Pure.Address as Address
-import qualified Cardano.Wallet.Deposit.Pure.Submissions as Sbm
-import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory as UTxOHistory
-import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Data.ByteString.Base16 as B16
-import qualified Data.ByteString.Char8 as B8
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-
-data WalletPublicIdentity = WalletPublicIdentity
- { pubXpub :: XPub
- , pubNextUser :: Word31
- }
- deriving (Show)
-
-data Credentials
- = XPubCredentials !XPub
- | XPrvCredentials !XPrv !XPub
- deriving (Generic, Show, Eq)
-
-instance Show XPrv where
- show = B8.unpack . B16.encode . rawSerialiseXPrv
-
-instance Eq XPrv where
- a == b = rawSerialiseXPrv a == rawSerialiseXPrv b
-
--- | Get /account/ 'XPub' from credentials if available.
---
--- The account public key corresponds to the account
--- private key obtained from 'deriveAccountXPrv',
--- /not/ the root private key.
-accountXPubFromCredentials :: Credentials -> XPub
-accountXPubFromCredentials (XPubCredentials xpub) = xpub
-accountXPubFromCredentials (XPrvCredentials _ xpub) = xpub
-
--- | Derive account 'XPrv' from the root 'XPrv'.
-deriveAccountXPrv :: XPrv -> XPrv
-deriveAccountXPrv xprv =
- ( deriveXPrvHard
- ( deriveXPrvHard
- ( deriveXPrvHard
- xprv
- 1857 -- Address derivation standard
- )
- 1815 -- ADA
- )
- 0 -- Account number
- )
-
--- | Get root 'XPrv' from credentials if available.
-rootXPrvFromCredentials :: Credentials -> Maybe XPrv
-rootXPrvFromCredentials (XPubCredentials _) = Nothing
-rootXPrvFromCredentials (XPrvCredentials xprv _) = Just xprv
-
-fromCredentialsAndGenesis
- :: Credentials -> Word31 -> Read.GenesisData -> WalletState
-fromCredentialsAndGenesis credentials customers genesisData =
- WalletState
- { walletTip = Read.GenesisPoint
- , addresses =
- Address.fromXPubAndCount
- network
- (accountXPubFromCredentials credentials)
- customers
- , utxoHistory = UTxOHistory.fromOrigin initialUTxO
- , txHistory = mempty
- , submissions = Sbm.empty
- , rootXSignKey = rootXPrvFromCredentials credentials
- }
- where
- network = Read.getNetworkId genesisData
- initialUTxO = mempty
-
--- | Simplified version of 'mkSomeMnemonic' that takes a space-separated list of
--- words. Entropy and checksum are checked as well.
-createMnemonicFromWords
- :: Text -> Either (MkSomeMnemonicError '[15, 24]) SomeMnemonic
-createMnemonicFromWords = mkSomeMnemonic . T.words
-
--- | Create 'Credentials' from a mnemonic sentence and a passphrase.
-credentialsFromMnemonics
- :: SomeMnemonic
- -- ^ Mnemonics
- -> Text
- -- ^ Passphrase
- -> Credentials
-credentialsFromMnemonics mnemonics passphrase =
- let
- unencryptedXPrv =
- genMasterKeyFromMnemonicShelley
- mnemonics
- (T.encodeUtf8 mempty)
- encryptedXPrv =
- xPrvChangePass
- B8.empty
- (T.encodeUtf8 passphrase)
- unencryptedXPrv
- in
- XPrvCredentials
- encryptedXPrv
- $ toXPub
- $ deriveAccountXPrv unencryptedXPrv
-
-data CanSign = CanSign | CannotSign
- deriving (Eq, Show)
-
-canSign :: WalletState -> CanSign
-canSign WalletState{rootXSignKey} = case rootXSignKey of
- Nothing -> CannotSign
- Just _ -> CanSign
-
--- | Create 'Credentials' from an extended public key failures to decode
-data ErrDecodingXPub = ErrFromXPubBase16 | ErrFromXPubDecodeKey
- deriving (Show, Eq)
-
--- | Create 'Credentials' from an extended public key encoded in base16.
-credentialsFromEncodedXPub
- :: Text
- -> Either ErrDecodingXPub Credentials
-credentialsFromEncodedXPub xpub = case B16.decode (T.encodeUtf8 xpub) of
- Left _ -> Left ErrFromXPubBase16
- Right bytes -> case xpubFromBytes bytes of
- Nothing -> Left ErrFromXPubDecodeKey
- Just key -> Right $ XPubCredentials key
-
--- | Encode an extended public key to base16.
-encodedXPubFromCredentials
- :: Credentials
- -> Text
-encodedXPubFromCredentials (XPubCredentials xpub) =
- T.decodeUtf8
- $ B16.encode
- $ xpubToBytes xpub
-encodedXPubFromCredentials (XPrvCredentials _ xpub) =
- encodedXPubFromCredentials (XPubCredentials xpub)
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment.hs
deleted file mode 100644
index 566e646729f..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment.hs
+++ /dev/null
@@ -1,344 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NoFieldSelectors #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Cardano.Wallet.Deposit.Pure.State.Payment
- ( ErrCreatePayment (..)
- , createPayment
- , createPaymentTxBody
- , CurrentEraResolvedTx
- , resolveCurrentEraTx
- , translateBalanceTxError
- ) where
-
-import Prelude hiding
- ( lookup
- )
-
-import Cardano.Ledger.Val
- ( isAdaOnly
- )
-import Cardano.Wallet.Deposit.Pure.State.Submissions
- ( availableUTxO
- )
-import Cardano.Wallet.Deposit.Pure.State.Type
- ( WalletState (..)
- )
-import Cardano.Wallet.Deposit.Pure.UTxO.Tx
- ( ResolvedTx (..)
- , resolveInputs
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- )
-import Cardano.Wallet.Deposit.Write
- ( Coin
- , Tx
- , TxBody (..)
- , Value
- )
-import Cardano.Wallet.Primitive.Types.Tx.Constraints
- ( TxSize (..)
- )
-import Cardano.Wallet.Read
- ( AssetID (AdaID)
- , Coin (..)
- , fromEraValue
- , injectCoin
- , lookupAssetID
- , toMaryValue
- )
-import Control.Monad.Trans.Except
- ( runExceptT
- )
-import Data.Bifunctor
- ( first
- )
-import Data.Digest.CRC32
- ( crc32
- )
-import Data.Fixed
- ( E6
- , Fixed
- )
-import Data.Text
- ( Text
- )
-import Data.Text.Class.Extended
- ( ToText (..)
- )
-import Numeric.Natural
- ( Natural
- )
-
-import qualified Cardano.Read.Ledger.Value as Read.L
-import qualified Cardano.Wallet.Deposit.Pure.Address as Address
-import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Cardano.Wallet.Deposit.Write as Write
-import qualified Cardano.Wallet.Read.Hash as Hash
-import qualified Control.Monad.Random.Strict as Random
-import qualified Data.Map.Strict as Map
-import qualified Data.Text as T
-
-data ErrCreatePayment
- = ErrCreatePaymentNotRecentEra (Read.EraValue Read.Era)
- | ErrNotEnoughAda { shortfall :: Value }
- | ErrEmptyUTxO
-
- | ErrTxOutAdaInsufficient { outputIx :: Int, suggestedMinimum :: Coin }
-
- -- | Only possible when sending (non-ada) assets.
- | ErrTxOutValueSizeExceedsLimit { outputIx :: Int }
-
- -- | Only possible when sending (non-ada) assets.
- | ErrTxOutTokenQuantityExceedsLimit
- { outputIx :: Int
- , quantity :: Natural
- , quantityMaxBound :: Natural
- }
-
- -- | The final balanced tx was too big. Either because the payload was too
- -- big to begin with, or because we failed to select enough inputs without
- -- making it too big, e.g. due to the UTxO containing lots of dust.
- --
- -- We should ideally split out 'TooManyPayments' from this error.
- -- We should ideally also be able to create payments even when dust causes
- -- us to need preparatory txs.
- | ErrTxMaxSizeLimitExceeded{ size :: TxSize, maxSize :: TxSize }
- deriving (Eq, Show)
-
-translateBalanceTxError :: Write.ErrBalanceTx Write.Conway -> ErrCreatePayment
-translateBalanceTxError = \case
- Write.ErrBalanceTxAssetsInsufficient
- Write.ErrBalanceTxAssetsInsufficientError{shortfall} ->
- ErrNotEnoughAda
- { shortfall = fromLedgerValue shortfall
- }
- Write.ErrBalanceTxMaxSizeLimitExceeded{size, maxSize} ->
- ErrTxMaxSizeLimitExceeded{size, maxSize}
- Write.ErrBalanceTxExistingKeyWitnesses _ ->
- impossible "ErrBalanceTxExistingKeyWitnesses"
- Write.ErrBalanceTxExistingCollateral ->
- impossible "ErrBalanceTxExistingCollateral"
- Write.ErrBalanceTxExistingTotalCollateral ->
- impossible "ErrBalanceTxExistingTotalCollateral"
- Write.ErrBalanceTxExistingReturnCollateral ->
- impossible "ErrBalanceTxExistingReturnCollateral"
- Write.ErrBalanceTxInsufficientCollateral _ ->
- impossible "ErrBalanceTxInsufficientCollateral"
- Write.ErrBalanceTxAssignRedeemers _ ->
- impossible "ErrBalanceTxAssignRedeemers"
- Write.ErrBalanceTxInternalError e ->
- impossible $ show e
- Write.ErrBalanceTxInputResolutionConflicts _ ->
- -- We are never creating partialTxs with pre-selected inputs, which
- -- means this is impossible.
- impossible "conflicting input resolution"
- Write.ErrBalanceTxUnresolvedInputs _ ->
- -- We are never creating partialTxs with pre-selected inputs, which
- -- means this is impossible.
- impossible "unresolved inputs"
- Write.ErrBalanceTxUnresolvedRefunds _ ->
- impossible "unresolved refunds"
- Write.ErrBalanceTxOutputError (Write.ErrBalanceTxOutputErrorOf ix info) -> case info of
- Write.ErrBalanceTxOutputAdaQuantityInsufficient{minimumExpectedCoin} ->
- ErrTxOutAdaInsufficient
- { outputIx = ix
- , suggestedMinimum = minimumExpectedCoin
- }
- Write.ErrBalanceTxOutputSizeExceedsLimit{} ->
- ErrTxOutValueSizeExceedsLimit
- { outputIx = ix
- }
- Write.ErrBalanceTxOutputTokenQuantityExceedsLimit{quantity, quantityMaxBound} ->
- ErrTxOutTokenQuantityExceedsLimit
- { outputIx = ix
- , quantity
- , quantityMaxBound
- }
- Write.ErrBalanceTxUnableToCreateChange
- Write.ErrBalanceTxUnableToCreateChangeError{shortfall} ->
- ErrNotEnoughAda
- { shortfall = injectCoin shortfall
- }
- Write.ErrBalanceTxUnableToCreateInput ->
- ErrEmptyUTxO
-
- where
- fromLedgerValue v = fromEraValue (Read.L.Value v :: Read.L.Value Write.Conway)
-
- impossible :: String -> a
- impossible reason = error $ "impossible: translateBalanceTxError: " <> reason
-
-instance ToText ErrCreatePayment where
- toText = \case
- ErrCreatePaymentNotRecentEra era ->
- "Cannot create a payment in the era: " <> showT era
- ErrNotEnoughAda{shortfall} -> T.unwords
- [ "Insufficient funds. Shortfall: ", prettyValue shortfall
- ]
- ErrEmptyUTxO -> "Wallet has no funds"
- ErrTxOutAdaInsufficient{outputIx, suggestedMinimum} -> T.unwords
- [ "Ada amount in output " <> showT outputIx
- , "is below the required minimum."
- , "Suggested minimum amount:", prettyCoin suggestedMinimum
- ]
- ErrTxMaxSizeLimitExceeded{size, maxSize} -> T.unlines
- [ "Exceeded the maximum size limit when creating the transaction."
- <> " (size: ", prettyTxSize size, " max size: ", prettyTxSize maxSize <> ")"
- , "\nPotential solutions:"
- , "1) Make fewer payments at the same time."
- , "2) Send smaller amounts of ada in total."
- , "3) Fund wallet with more ada."
- , "4) Make preparatory payments to yourself to coalesce dust into"
- , "larger UTxOs."
- ]
- ErrTxOutValueSizeExceedsLimit{outputIx} -> T.unwords
- [ "The size of the value of output", showT outputIx, "is too large."
- , "Try sending fewer assets or splitting them over multiple outputs."
- ]
- ErrTxOutTokenQuantityExceedsLimit{outputIx, quantity, quantityMaxBound} -> T.unwords
- [ "The asset quantity of ", showT quantity, "in output"
- , showT outputIx, ", is larger than the maximum allowed"
- , "limit", showT quantityMaxBound <> "."
- ]
- where
- showT :: Show a => a -> Text
- showT = T.pack . show
-
- prettyTxSize :: TxSize -> Text
- prettyTxSize (TxSize s) = T.pack (show s)
-
- prettyValue :: Value -> Text
- prettyValue v
- | isAdaOnly (toMaryValue v) = prettyCoin (CoinC $ lookupAssetID AdaID v)
- | otherwise = T.pack (show v)
-
- prettyCoin :: Coin -> Text
- prettyCoin c = T.pack (show c') <> "₳"
- where
- c' :: Fixed E6
- c' = toEnum $ fromEnum c
-
-type CurrentEraResolvedTx = ResolvedTx Read.Conway
-
-resolveCurrentEraTx :: Tx -> WalletState -> CurrentEraResolvedTx
-resolveCurrentEraTx tx w = resolveInputs (availableUTxO w) tx
-
-createPayment
- :: Read.EraValue Read.PParams
- -> Write.TimeTranslation
- -> [(Address, Write.Value)]
- -> WalletState
- -> Either ErrCreatePayment CurrentEraResolvedTx
-createPayment pp tt destinations w =
- createPaymentTxBody pp tt (mkPaymentTxBody w destinations) w
-
--- | Create a payment to a list of destinations.
-createPaymentTxBody
- :: Read.EraValue Read.PParams
- -> Write.TimeTranslation
- -> TxBody
- -> WalletState
- -> Either ErrCreatePayment CurrentEraResolvedTx
-createPaymentTxBody
- (Read.EraValue (Read.PParams pparams :: Read.PParams era))
- timeTranslation
- txBody
- state =
- case Read.theEra :: Read.Era era of
- Read.Conway ->
- first translateBalanceTxError
- $ flip resolveCurrentEraTx state
- <$> createPaymentConway
- pparams
- timeTranslation
- txBody
- state
- era' -> Left $ ErrCreatePaymentNotRecentEra (Read.EraValue era')
-
-mkPaymentTxBody
- :: WalletState -> [(Address, Write.Value)] -> Write.TxBody
-mkPaymentTxBody w destinations =
- Write.TxBody
- { spendInputs = mempty
- , collInputs = mempty
- , txouts =
- Map.fromList
- $ zip [(toEnum 0) ..]
- $ map (uncurry Write.mkTxOut) destinations
- , collRet = Nothing
- , expirySlot = Just . computeExpirySlot $ walletTip w
- }
-
--- | In the Conway era: Create a payment to a list of destinations.
-createPaymentConway
- :: Write.PParams Write.Conway
- -> Write.TimeTranslation
- -> TxBody
- -> WalletState
- -> Either (Write.ErrBalanceTx Write.Conway) Write.Tx
-createPaymentConway pparams timeTranslation body w =
- fmap (Read.Tx . fst)
- . flip Random.evalRand (pilferRandomGen w)
- . runExceptT
- . balance
- (availableUTxO w)
- (addresses w)
- . mkPartialTx
- $ body
- where
- mkPartialTx :: Write.TxBody -> Write.PartialTx Write.Conway
- mkPartialTx txbody =
- Write.PartialTx
- { tx = Read.unTx $ Write.mkTx txbody
- , extraUTxO = mempty :: Write.UTxO Write.Conway
- , redeemers = mempty
- , stakeKeyDeposits = Write.StakeKeyDepositMap mempty
- , timelockKeyWitnessCounts = Write.TimelockKeyWitnessCounts mempty
- }
-
- balance utxo addressState =
- Write.balanceTx
- pparams
- timeTranslation
- Write.AllKeyPaymentCredentials
- (Write.constructUTxOIndex $ Write.toConwayUTxO utxo)
- (changeAddressGen addressState)
- ()
-
- changeAddressGen s =
- Write.ChangeAddressGen
- { Write.genChangeAddress =
- first Read.decompactAddr . Address.newChangeAddress s
- , Write.maxLengthChangeAddress =
- Read.decompactAddr $ Address.mockMaxLengthChangeAddress s
- }
-
--- | Use entropy contained in the current 'WalletState'
--- to construct a pseudorandom seed.
--- (NOT a viable source of cryptographic randomness.)
---
--- Possible downsides of this approach:
---
--- 1. security/privacy
--- 2. concurrency
--- 3. retries for different coin selections
-pilferRandomGen :: WalletState -> Random.StdGen
-pilferRandomGen =
- Random.mkStdGen . fromEnum . fromChainPoint . walletTip
- where
- fromChainPoint (Read.GenesisPoint) = 0
- fromChainPoint (Read.BlockPoint _ headerHash) =
- crc32 $ Hash.hashToBytes headerHash
-
--- | Compute an expiry slot from a current 'ChainPoint'.
-computeExpirySlot :: Read.ChainPoint -> Read.SlotNo
-computeExpirySlot Read.GenesisPoint = 0
-computeExpirySlot (Read.BlockPoint slotNo _) =
- slotNo + hour
- where
- hour = 60 * 60
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment/Inspect.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment/Inspect.hs
deleted file mode 100644
index 9cb26bbdc46..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Payment/Inspect.hs
+++ /dev/null
@@ -1,128 +0,0 @@
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Cardano.Wallet.Deposit.Pure.State.Payment.Inspect
- ( inspectTx
- , CurrentEraResolvedTx
- , InspectTx (..)
- , transactionBalance
- ) where
-
-import Prelude
-
-import Cardano.Read.Ledger.Tx.Fee
- ( Fee (..)
- , getEraFee
- )
-import Cardano.Read.Ledger.Tx.Output
- ( Output (..)
- )
-import Cardano.Read.Ledger.Tx.Outputs
- ( Outputs (..)
- , getEraOutputs
- )
-import Cardano.Wallet.Deposit.Pure.Address
- ( Customer
- , isChangeAddress
- )
-import Cardano.Wallet.Deposit.Pure.State.Payment
- ( CurrentEraResolvedTx
- )
-import Cardano.Wallet.Deposit.Pure.State.Type
- ( WalletState (..)
- , addressToCustomer
- )
-import Cardano.Wallet.Deposit.Pure.UTxO.Tx
- ( ResolvedTx (..)
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- , TxId
- )
-import Cardano.Wallet.Read
- ( Coin (..)
- , Conway
- , TxIx
- , Value (..)
- , getCompactAddr
- , getInputs
- , getValue
- , mkEraTxOut
- , pattern TxIn
- )
-import Control.Lens
- ( Field2 (_2)
- , Field3 (_3)
- , to
- , (^.)
- )
-import Data.Foldable
- ( Foldable (..)
- , fold
- )
-import Data.Monoid
- ( Sum (..)
- )
-
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-
--- | Inspect the inputs and outputs of a transaction.
-data InspectTx = InspectTx
- { ourInputs :: [(TxId, TxIx, Coin)]
- -- ^ Our inputs.
- , otherInputs :: [(TxId, TxIx)]
- -- ^ Other inputs, there shouldn't be any.
- , change :: [(Address, Coin)]
- -- ^ Change outputs.
- , ourOutputs :: [(Address, Customer, Coin)]
- -- ^ Our outputs. The customer is the owner of the address. There could be
- -- reasons the user wants to move funds among customer addresses.
- , otherOutputs :: [(Address, Coin)]
- -- ^ Other outputs. This is regular money leaving the wallet.
- , fee :: Coin
- }
- deriving (Eq, Show)
-
--- | Calculate the output balance of a transaction, which is the sum of the
--- values of our inputs minus the sum of the values of the change outputs and
--- minus the outputs to our customers.
-transactionBalance :: InspectTx -> Integer
-transactionBalance InspectTx{..} = getSum $
- (ourInputs ^. traverse . _3 . mkSum)
- - (change ^. traverse . _2 . mkSum)
- - (ourOutputs ^. traverse . _3 . mkSum)
- where
- mkSum = to (Sum . unCoin)
-
--- | Inspect a transaction where inputs have been resolved to our UTxO.
-inspectTx :: WalletState -> CurrentEraResolvedTx -> InspectTx
-inspectTx ws (ResolvedTx tx ourUTxO) =
- let
- (ourInputs, otherInputs) = fold $ do
- in'@(TxIn txId txIx) <- Set.toList $ getInputs tx
- case Map.lookup in' ourUTxO of
- Just out -> do
- let ValueC coins _ = getValue out
- pure ([(txId, txIx, coins)], [])
- Nothing -> [([], [(txId, txIx)])]
- (change, ourOutputs, otherOutputs) = fold $ do
- out <-
- fmap (mkEraTxOut @Conway . Output)
- $ toList
- $ (\(Outputs outs) -> outs)
- $ getEraOutputs tx
- let addr = getCompactAddr out
- ValueC coins _ = getValue out
- contrib = pure (addr, coins)
- if
- | isChangeAddress (addresses ws) addr -> [(contrib, [], [])]
- | otherwise ->
- case addressToCustomer addr ws of
- Just customer -> [([], [(addr, customer, coins)], [])]
- Nothing -> [([], [], contrib)]
- Fee fee = getEraFee tx
- in
- InspectTx{..}
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Rolling.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Rolling.hs
deleted file mode 100644
index 540773f84a4..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Rolling.hs
+++ /dev/null
@@ -1,117 +0,0 @@
-module Cardano.Wallet.Deposit.Pure.State.Rolling
- ( rollForwardMany
- , rollForwardOne
- , rollBackward
- ) where
-
-import Prelude hiding
- ( lookup
- )
-
-import Cardano.Wallet.Deposit.Pure.Balance
- ( ValueTransferMap
- )
-import Cardano.Wallet.Deposit.Pure.State.Type
-import Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory
- ( UTxOHistory
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- , getEraSlotOfBlock
- )
-import Cardano.Wallet.Deposit.Time
- ( LookupTimeFromSlot
- )
-import Data.Foldable
- ( Foldable (..)
- , foldl'
- )
-import Data.List.NonEmpty
- ( NonEmpty
- )
-
-import qualified Cardano.Wallet.Deposit.Pure.Address as Address
-import qualified Cardano.Wallet.Deposit.Pure.API.TxHistory as TxHistory
-import qualified Cardano.Wallet.Deposit.Pure.Balance as Balance
-import qualified Cardano.Wallet.Deposit.Pure.RollbackWindow as Rollback
-import qualified Cardano.Wallet.Deposit.Pure.Submissions as Sbm
-import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory as UTxOHistory
-import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Data.Delta as Delta
-
-rollForwardMany
- :: LookupTimeFromSlot
- -> NonEmpty (Read.EraValue Read.Block)
- -> WalletState
- -> WalletState
-rollForwardMany timeFromSlot blocks w =
- foldl' (flip $ rollForwardOne timeFromSlot) w blocks
-
-rollForwardOne
- :: LookupTimeFromSlot
- -> Read.EraValue Read.Block
- -> WalletState
- -> WalletState
-rollForwardOne timeFromSlot (Read.EraValue block) w =
- w
- { walletTip = Read.getChainPoint block
- , utxoHistory = utxoHistory'
- , submissions = Delta.apply (Sbm.rollForward block) (submissions w)
- , txHistory =
- TxHistory.rollForward
- valueTransfers
- (`addressToCustomer` w)
- timeFromSlot
- (getEraSlotOfBlock block)
- (txHistory w)
- }
- where
- (utxoHistory', valueTransfers) =
- rollForwardUTxO isOurs block (utxoHistory w)
- isOurs :: Address -> Bool
- isOurs = Address.isOurs (addresses w)
-
-rollForwardUTxO
- :: Read.IsEra era
- => (Address -> Bool)
- -> Read.Block era
- -> UTxOHistory
- -> (UTxOHistory, ValueTransferMap)
-rollForwardUTxO isOurs block u =
- (UTxOHistory.rollForward slot deltaUTxO u, valueTransfers)
- where
- (deltaUTxO, _, valueTransfers) =
- Balance.applyBlock isOurs block (UTxOHistory.getUTxO u)
- slot = Read.getEraSlotNo $ Read.getEraBHeader block
-
-rollBackward
- :: LookupTimeFromSlot
- -> Read.ChainPoint
- -> WalletState
- -> (WalletState, Read.ChainPoint)
-rollBackward timeFromSlot targetPoint w =
- ( w
- { walletTip = actualPoint
- , utxoHistory =
- UTxOHistory.rollBackward actualSlot (utxoHistory w)
- , submissions =
- Delta.apply (Sbm.rollBackward actualSlot) (submissions w)
- , txHistory =
- TxHistory.rollBackward timeFromSlot actualSlot (txHistory w)
- }
- , actualPoint
- )
- where
- h = utxoHistory w
-
- targetSlot = Read.slotFromChainPoint targetPoint
- actualSlot = Read.slotFromChainPoint actualPoint
-
- -- NOTE: We don't keep enough information about
- -- the block hashes to roll back to
- -- any other point than the target point (or genesis).
- actualPoint =
- if (targetSlot `Rollback.member` UTxOHistory.getRollbackWindow h)
- then -- FIXME: Add test for rollback window of `submissions`
- targetPoint
- else Read.GenesisPoint
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Signing.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Signing.hs
deleted file mode 100644
index 4d01c5ab989..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Signing.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-module Cardano.Wallet.Deposit.Pure.State.Signing
- ( getBIP32PathsForOwnedInputs
- , signTx
- , Passphrase
- ) where
-
-import Prelude
-
-import Cardano.Crypto.Wallet
- ( xPrvChangePass
- )
-import Cardano.Wallet.Address.BIP32
- ( BIP32Path (..)
- )
-import Cardano.Wallet.Address.BIP32_Ed25519
- ( deriveXPrvBIP32Path
- )
-import Cardano.Wallet.Deposit.Pure.State.Submissions
- ( availableUTxO
- )
-import Cardano.Wallet.Deposit.Pure.State.Type
- ( WalletState (..)
- )
-import Data.Maybe
- ( mapMaybe
- )
-import Data.Set
- ( Set
- )
-import Data.Text
- ( Text
- )
-
-import qualified Cardano.Wallet.Deposit.Pure.Address as Address
-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.ByteString as BS
-import qualified Data.Text.Encoding as T
-
-getBIP32PathsForOwnedInputs :: Write.Tx -> WalletState -> [BIP32Path]
-getBIP32PathsForOwnedInputs tx w =
- getBIP32Paths w $ resolveInputAddresses inputs
- where
- inputs = Read.getInputs tx <> Read.getCollateralInputs tx
-
- resolveInputAddresses :: Set Read.TxIn -> [Read.Address]
- resolveInputAddresses ins =
- map (Read.address . snd)
- . UTxO.toList
- $ UTxO.restrictedBy (availableUTxO w) ins
-
-getBIP32Paths :: WalletState -> [Read.Address] -> [BIP32Path]
-getBIP32Paths w =
- mapMaybe $ Address.getBIP32Path (addresses w)
-
-type Passphrase = Text
-
--- | Sign the transaction if 'rootXSignKey' is 'Just'.
-signTx :: Write.Tx -> Passphrase -> WalletState -> Maybe Write.Tx
-signTx tx passphrase w = signTx' <$> rootXSignKey w
- where
- signTx' encryptedXPrv =
- foldr Write.addSignature tx keys
- where
- unencryptedXPrv =
- xPrvChangePass
- (T.encodeUtf8 passphrase)
- BS.empty
- encryptedXPrv
- keys = deriveXPrvBIP32Path unencryptedXPrv
- <$> getBIP32PathsForOwnedInputs tx w
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Submissions.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Submissions.hs
deleted file mode 100644
index c829a9bc457..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Submissions.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-module Cardano.Wallet.Deposit.Pure.State.Submissions
- ( -- * Txs in submission queue management
- addTxSubmission
- , listTxsInSubmission
-
- -- * Balance considering pending transactions
- , availableBalance
- , availableUTxO
- ) where
-
-import Prelude hiding
- ( lookup
- )
-
-import Cardano.Wallet.Deposit.Pure.Balance
- ( balance
- )
-import Cardano.Wallet.Deposit.Pure.State.Type
- ( WalletState (..)
- )
-import Cardano.Wallet.Deposit.Read
- ( UTxO
- )
-import Cardano.Wallet.Read
- ( Value
- )
-
-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.UTxOHistory as UTxOHistory
-import qualified Cardano.Wallet.Deposit.Write as Write
-import qualified Data.Delta as Delta
-
-addTxSubmission :: Write.Tx -> WalletState -> WalletState
-addTxSubmission tx w =
- w
- { submissions = Delta.apply (Sbm.add tx) (submissions w)
- }
-
-listTxsInSubmission :: WalletState -> [Write.Tx]
-listTxsInSubmission = Sbm.listInSubmission . submissions
-
--- | Compute the available balance from the current 'WalletState' considering
--- the pending transactions in the submission queue.
-availableBalance :: WalletState -> Value
-availableBalance = balance . availableUTxO
-
--- | Compute the available UTxO from the current 'WalletState' considering
--- the pending transactions in the submission queue.
-availableUTxO :: WalletState -> UTxO
-availableUTxO w =
- Balance.availableUTxO utxo pending
- where
- pending = listTxsInSubmission w
- utxo = UTxOHistory.getUTxO $ utxoHistory w
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/TxHistory.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/TxHistory.hs
deleted file mode 100644
index 572a75bc6a5..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/TxHistory.hs
+++ /dev/null
@@ -1,108 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Cardano.Wallet.Deposit.Pure.State.TxHistory
- ( getTxHistoryByCustomer
- , getTxHistoryByTime
- , getEraSlotOfBlock
- , getCustomerDeposits
- , getAllDeposits
- ) where
-
-import Prelude hiding
- ( lookup
- )
-
-import Cardano.Wallet.Deposit.Map
- ( Map
- , W
- , lookupMap
- , value
- )
-import Cardano.Wallet.Deposit.Map.Timed
- ( Timed
- , TimedSeq
- , extractInterval
- , monoid
- )
-import Cardano.Wallet.Deposit.Pure.API.TxHistory
- ( ByCustomer
- , ByTime
- , DownTime
- , TxHistory (..)
- )
-import Cardano.Wallet.Deposit.Pure.State.Type
- ( Customer
- , WalletState (..)
- )
-import Cardano.Wallet.Deposit.Pure.UTxO.ValueTransfer
- ( ValueTransfer (..)
- )
-import Cardano.Wallet.Deposit.Read
- ( TxId
- , WithOrigin (..)
- , getEraSlotOfBlock
- )
-import Data.FingerTree
- ( Measured (..)
- )
-import Data.Foldable
- ( Foldable (..)
- , fold
- )
-import Data.Map.Monoidal.Strict
- ( MonoidalMap (..)
- )
-import Data.Ord
- ( Down (..)
- )
-import Data.Time
- ( UTCTime
- )
-
-import qualified Data.Map.Strict as Map
-
-getTxHistoryByCustomer :: WalletState -> ByCustomer
-getTxHistoryByCustomer state = byCustomer $ txHistory state
-
-getTxHistoryByTime :: WalletState -> ByTime
-getTxHistoryByTime state = byTime $ txHistory state
-
-getCustomerDeposits
- :: Customer
- -> Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
- -> WalletState
- -> Map.Map TxId ValueTransfer
-getCustomerDeposits c interval s = fold $ do
- fmap (wonders interval . value . snd)
- $ lookupMap c
- $ getTxHistoryByCustomer s
-
-getAllDeposits
- :: Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
- -> WalletState
- -> Map.Map Customer ValueTransfer
-getAllDeposits interval s =
- wonders interval
- $ value
- $ getTxHistoryByTime s
-
-wonders
- :: (Ord k, Monoid w, Foldable (Map xs), Monoid (Map xs ValueTransfer))
- => Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
- -> TimedSeq DownTime (Map (W w k : xs) ValueTransfer)
- -> Map.Map k ValueTransfer
-wonders interval =
- getMonoidalMap
- . monoid
- . fmap (fmap fold . value)
- . extractInterval' interval
- where
- extractInterval'
- :: Monoid a
- => Maybe (WithOrigin UTCTime, WithOrigin UTCTime)
- -> TimedSeq (DownTime) a
- -> Timed (DownTime) a
- extractInterval' Nothing = measure
- extractInterval' (Just (t1, t2)) = extractInterval (Down t1) (Down t2)
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Type.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Type.hs
deleted file mode 100644
index 5868d614a89..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/State/Type.hs
+++ /dev/null
@@ -1,127 +0,0 @@
-{-# LANGUAGE StrictData #-}
-module Cardano.Wallet.Deposit.Pure.State.Type
- ( -- * Types
- WalletState (..)
- , DeltaWalletState
- , Customer
-
- -- * Operations
- , listCustomers
- , customerAddress
- , addressToCustomer
- , deriveAddress
- , knownCustomer
- , knownCustomerAddress
- , isCustomerAddress
- , fromRawCustomer
- , trackedCustomers
- , walletXPub
- , getUTxO
- , getWalletTip
- , networkTag
- ) where
-
-import Prelude hiding
- ( lookup
- )
-
-import Cardano.Crypto.Wallet
- ( XPrv
- , XPub
- )
-import Cardano.Wallet.Deposit.Pure.API.TxHistory
- ( TxHistory (..)
- )
-import Cardano.Wallet.Deposit.Read
- ( NetworkTag
- )
-import Cardano.Wallet.Deposit.Write
- ( Address
- )
-import Data.Word.Odd
- ( Word31
- )
-
-import qualified Cardano.Wallet.Deposit.Pure.Address as Address
-import qualified Cardano.Wallet.Deposit.Pure.Submissions as Sbm
-import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxO as UTxO
-import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory as UTxOHistory
-import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Data.Delta as Delta
-import qualified Data.List as L
-import qualified Data.Map.Strict as Map
-
-type Customer = Address.Customer
-
-data WalletState = WalletState
- { walletTip :: Read.ChainPoint
- -- ^ The wallet includes information from all blocks until
- -- and including this one.
- , addresses :: Address.AddressState
- -- ^ Addresses and public keys known to this wallet.
- , utxoHistory :: UTxOHistory.UTxOHistory
- -- ^ UTxO of this wallet, with support for rollbacks.
- , txHistory :: TxHistory
- -- ^ (Summarized) transaction history of this wallet.
- , submissions :: Sbm.TxSubmissions
- -- ^ Queue of pending transactions.
- , rootXSignKey :: Maybe XPrv
- -- ^ Maybe a private key for signing transactions.
- -- , info :: WalletInfo
- }
-
-type DeltaWalletState = Delta.Replace WalletState
-
-listCustomers :: WalletState -> [(Customer, Address)]
-listCustomers =
- Address.listCustomers . addresses
-
-customerAddress :: Customer -> WalletState -> Maybe Address
-customerAddress c = L.lookup c . listCustomers
-
-addressToCustomer :: Address -> WalletState -> Maybe Customer
-addressToCustomer address =
- Map.lookup address
- . Map.fromList
- . fmap (\(a, c) -> (c, a))
- . listCustomers
-
--- depend on the public key only, not on the entire wallet state
-deriveAddress :: WalletState -> (Customer -> Address)
-deriveAddress w =
- Address.deriveCustomerAddress
- (Address.getNetworkTag as)
- (Address.getXPub as)
- where
- as = addresses w
-
--- FIXME: More performant with a double index.
-knownCustomer :: Customer -> WalletState -> Bool
-knownCustomer c = (c `elem`) . map fst . listCustomers
-
-knownCustomerAddress :: Address -> WalletState -> Bool
-knownCustomerAddress address =
- Address.knownCustomerAddress address . addresses
-
-isCustomerAddress :: Address -> WalletState -> Bool
-isCustomerAddress address =
- flip Address.isCustomerAddress address . addresses
-
-fromRawCustomer :: Word31 -> Customer
-fromRawCustomer = id
-
--- | Maximum 'Customer' that is being tracked.
-trackedCustomers :: WalletState -> Customer
-trackedCustomers = (+1) . Address.getMaxCustomer . addresses
-
-walletXPub :: WalletState -> XPub
-walletXPub = Address.getXPub . addresses
-
-getUTxO :: WalletState -> UTxO.UTxO
-getUTxO = UTxOHistory.getUTxO . utxoHistory
-
-getWalletTip :: WalletState -> Read.ChainPoint
-getWalletTip = walletTip
-
-networkTag :: WalletState -> NetworkTag
-networkTag = Address.getNetworkTag . addresses
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs
deleted file mode 100644
index 8d05a68e832..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/Submissions.hs
+++ /dev/null
@@ -1,105 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE StrictData #-}
-{-# 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 qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Cardano.Wallet.Deposit.Write as Write
-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
-import qualified Data.Map.Strict as Map
-
-{-----------------------------------------------------------------------------
- Types
-------------------------------------------------------------------------------}
-type ExpirySlot = WithInfinity Read.Slot
-
-type TxSubmissions
- = Sbm.Submissions () ExpirySlot (Read.TxId, Write.Tx)
-type TxSubmissionsStatus
- = Sbm.TxStatusMeta () ExpirySlot(Read.TxId, Write.Tx)
-type DeltaTxSubmissions1
- = Sbm.Operation () ExpirySlot (Read.TxId, Write.Tx)
-type DeltaTxSubmissions
- = [DeltaTxSubmissions1]
-
-instance Delta.Delta DeltaTxSubmissions1 where
- type Base DeltaTxSubmissions1 = TxSubmissions
- apply = Sbm.applyOperations
-
-instance Sbm.HasTxId (Read.TxId, Write.Tx) where
- type TxId (Read.TxId, Write.Tx) = Read.TxId
- txId = fst
-
--- | Data type used for tracking transactions
--- that will never become invalid.
-data WithInfinity a
- = Finite a
- | Infinity
- deriving (Eq, Show)
-
-infinityFromNothing :: Maybe a -> WithInfinity a
-infinityFromNothing Nothing = Infinity
-infinityFromNothing (Just x) = Finite x
-
-instance Ord a => Ord (WithInfinity a) where
- compare (Finite x) (Finite y) = compare x y
- compare Infinity (Finite _) = GT
- compare (Finite _) Infinity = LT
- compare Infinity Infinity = EQ
-
-instance Functor WithInfinity where
- fmap f (Finite x) = Finite (f x)
- fmap _ Infinity = Infinity
-
-{-----------------------------------------------------------------------------
- Operations
-------------------------------------------------------------------------------}
--- | Empty collection of transaction in submission.
-empty :: TxSubmissions
-empty = Sbm.mkEmpty (Finite Read.Origin)
-
--- | Add a /new/ transaction to the local submission pool.
-add :: Write.Tx -> DeltaTxSubmissions
-add tx = [ Sbm.AddSubmission expiry (txId, tx) () ]
- where
- txId = Read.getTxId tx
- expiry =
- fmap Read.At
- . infinityFromNothing
- . Read.invalidHereafter
- $ Read.getValidityInterval tx
-
--- | List of transactions that are in submission, in no particular order.
-listInSubmission :: TxSubmissions -> [Write.Tx]
-listInSubmission submissions = do
- Sbm.InSubmission _ (_, tx) <- Map.elems (Sbm.transactions submissions)
- pure tx
-
--- | Rollforward the transactions that are in submission
-rollForward :: Read.IsEra era => Read.Block era -> DeltaTxSubmissions
-rollForward block = [ Sbm.RollForward slot txids ]
- where
- slot = Finite $ Read.slotFromChainPoint $ Read.getChainPoint block
- txids = map ((slot,) . Read.getTxId) $ Read.getEraTransactions block
-
--- | Roll backward the transactions that are in submission
-rollBackward :: Read.Slot -> DeltaTxSubmissions
-rollBackward slot = [ Sbm.RollBack (Finite slot) ]
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs
deleted file mode 100644
index 494643d9ce9..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Pure/UTxO.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module Cardano.Wallet.Deposit.Pure.UTxO
- ( UTxO
- , balance
- , excluding
- , restrictedBy
- , filterByAddress
- , toList
-
- , DeltaUTxO
- , excludingD
- , receiveD
- , null
- ) where
-
-import Cardano.Wallet.Deposit.Pure.UTxO.DeltaUTxO
- ( DeltaUTxO
- , excludingD
- , null
- , receiveD
- )
-import Cardano.Wallet.Deposit.Pure.UTxO.UTxO
- ( UTxO
- , balance
- , excluding
- , filterByAddress
- , restrictedBy
- )
-import Data.Map.Strict
- ( toList
- )
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs
deleted file mode 100644
index 25463a01fcd..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs
+++ /dev/null
@@ -1,137 +0,0 @@
-{-# LANGUAGE BinaryLiterals #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
--- | 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
- ( Read.IsEra (..)
- , Read.Era (..)
- , Read.EraValue (..)
- , Read.Conway
- , Read.getEra
-
- , Read.SlotNo (..)
- , Read.ChainPoint (..)
- , Read.Slot
- , Read.WithOrigin (..)
- , Read.slotFromChainPoint
-
- , Address
- , KeyHash
- , NetworkTag (..)
- , mkEnterpriseAddress
- , Addr
- , compactAddr
- , decompactAddr
-
- , Ix
- , Read.TxIn
- , Read.TxOut
- , address
- , Read.Value
- , Read.lessOrEqual
- , UTxO
-
- , Read.TxId
- , Read.Tx (..)
- , Read.utxoFromEraTx
- , Read.getCollateralInputs
- , Read.getInputs
- , Read.getValidityInterval
- , Read.getTxId
- , Read.invalidHereafter
-
- , Read.Block
- , Read.getChainPoint
- , Read.getEraBHeader
- , Read.getEraSlotNo
- , Read.getEraTransactions
- , mockNextBlock
- , Read.mockRawHeaderHash
-
- , Read.ChainTip (..)
- , Read.getChainTip
- , Read.prettyChainTip
-
- , Read.PParams (..)
- , Read.mockPParamsConway
-
- , Read.GenesisData
- , Read.GenesisHash
- , Read.mockGenesisDataMainnet
-
- , Read.NetworkId (Read.Mainnet, Read.Testnet)
- , Read.getNetworkId
- , getEraSlotOfBlock
- ) where
-
-import Prelude
-
-import Cardano.Ledger.Address
- ( Addr
- , compactAddr
- , decompactAddr
- )
-import Cardano.Wallet.Address.Encoding
- ( Credential (..)
- , EnterpriseAddr (..)
- , KeyHash
- , NetworkTag (..)
- , compactAddrFromEnterpriseAddr
- )
-import Cardano.Wallet.Read.Block.Gen
- ( mkBlockEra
- )
-import Cardano.Wallet.Read.Block.Gen.BlockParameters
- ( BlockParameters (..)
- )
-import Data.Map
- ( Map
- )
-
-import qualified Cardano.Wallet.Read as Read
-
-{-----------------------------------------------------------------------------
- Type definitions
- with dummies
-------------------------------------------------------------------------------}
-
--- | Synonym for readability.
--- The ledger specifications define @Addr@.
--- Byron addresses are represented by @Addr_bootstrap@.
-type Address = Read.CompactAddr
-
--- | Make an enterprise address from a given network and key hash.
-mkEnterpriseAddress :: NetworkTag -> KeyHash -> Address
-mkEnterpriseAddress network =
- compactAddrFromEnterpriseAddr
- . EnterpriseAddrC network
- . KeyHashObj
-
-type Ix = Read.TxIx
-
-address :: Read.TxOut -> Address
-address = Read.getCompactAddr
-
-type UTxO = Map Read.TxIn Read.TxOut
-
-{-----------------------------------------------------------------------------
- Block
-------------------------------------------------------------------------------}
--- | Create a new block from a sequence of transaction.
-mockNextBlock
- :: Read.ChainPoint -> [Read.Tx Read.Conway] -> Read.Block Read.Conway
-mockNextBlock old txs =
- mkBlockEra BlockParameters{slotNumber,blockNumber,txs}
- where
- blockNumber = Read.BlockNo $ Read.unSlotNo slotNumber
- slotNumber = case old of
- Read.GenesisPoint -> Read.SlotNo 0
- Read.BlockPoint{slotNo = n} -> succ n
-
-getEraSlotOfBlock :: Read.IsEra era => Read.Block era -> Read.Slot
-getEraSlotOfBlock = Read.At . Read.getEraSlotNo . Read.getEraBHeader
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs
deleted file mode 100644
index 6b8373f1d89..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs
+++ /dev/null
@@ -1,422 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Cardano.Wallet.Deposit.Testing.DSL
- ( Scenario (..)
- , ScenarioP
- , existsTx
- , deposit
- , deposit_
- , withdrawal
- , block
- , rollForward
- , rollBackward
- , historyByTime
- , historyByCustomer
- , newHistoryByTime
- , availableBalance
- , assert
- , interpret
- , InterpreterState (..)
- , spend
- , sign
- , utxo
- , wallet
- , balance
- )
-where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.Pure
- ( Customer
- , ResolvedTx (..)
- , WalletState
- , getTxHistoryByTime
- )
-import Cardano.Wallet.Deposit.Pure.API.TxHistory
- ( ByCustomer
- , ByTime
- , LookupTimeFromSlot
- )
-import Cardano.Wallet.Deposit.Pure.State.Creation
- ( createMnemonicFromWords
- , credentialsFromMnemonics
- )
-import Cardano.Wallet.Deposit.Pure.State.Payment
- ( createPaymentTxBody
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- , ChainPoint (..)
- , EraValue (..)
- , UTxO
- , getChainPoint
- , mockNextBlock
- , slotFromChainPoint
- )
-import Cardano.Wallet.Deposit.Testing.DSL.ByTime
- ( ByTimeM
- , ByTimeMContext (..)
- )
-import Cardano.Wallet.Deposit.Testing.DSL.Types
- ( BlockI (..)
- , TxI (..)
- , UnspentI (..)
- )
-import Cardano.Wallet.Deposit.Write
- ( Block
- , Tx
- , TxBody
- , addTxIn
- , addTxOut
- , emptyTxBody
- , mkAda
- , mkTx
- , mkTxOut
- , txOutsL
- )
-import qualified Cardano.Wallet.Deposit.Write as Write
-import Cardano.Wallet.Read
- ( Coin (..)
- , Slot
- , Value (..)
- , WithOrigin
- , getTxId
- , pattern TxIn
- )
-import Control.Lens
- ( At (..)
- , Field1 (_1)
- , Field2 (_2)
- , Ixed (..)
- , Lens'
- , lens
- , use
- , uses
- , zoom
- , (%=)
- , (.=)
- , (^?)
- )
-import Control.Monad
- ( void
- , (>=>)
- )
-import Control.Monad.Operational
- ( ProgramT
- , ProgramViewT (..)
- , singleton
- , viewT
- )
-import Control.Monad.Reader
- ( MonadIO (..)
- , runReader
- )
-import Control.Monad.State
- ( MonadState (..)
- , MonadTrans (..)
- , StateT
- , evalStateT
- , execStateT
- , modify
- )
-import Data.List
- ( mapAccumL
- )
-import Data.Map
- ( Map
- )
-import Data.Maybe
- ( fromJust
- )
-import Data.Text
- ( Text
- )
-import Data.Time
- ( UTCTime
- )
-
-import qualified Cardano.Wallet.Deposit.Pure as Wallet
-import qualified Cardano.Wallet.Deposit.Time as Time
-import qualified Cardano.Wallet.Read as Read
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-data Scenario p a where
- ResetWallet :: Int -> Text -> Text -> Scenario p ()
- ExistsTx :: Scenario p TxI
- Deposit :: TxI -> Customer -> Int -> Scenario p UnspentI
- Spend :: TxI -> Address -> Int -> Scenario p ()
- Withdrawal :: TxI -> UnspentI -> Scenario p ()
- CreateBlock :: [TxI] -> Scenario p (BlockI)
- RollForward :: [BlockI] -> Scenario p ()
- RollBackward :: Maybe BlockI -> Scenario p ()
- HistoryByTime :: Scenario p ByTime
- HistoryByCustomer :: Scenario p ByCustomer
- NewHistoryByTime :: ByTimeM ByTime -> Scenario p ByTime
- AvailableBalance :: Scenario p Int
- Sign :: Tx -> Text -> Scenario p Tx
- Balance :: TxI -> Scenario p Tx
- UTxO :: UnspentI -> Scenario p UTxO
- Assert :: p -> Scenario p ()
-
-type ScenarioP p m = ProgramT (Scenario p) m
-
-wallet :: Int -> Text -> Text -> ScenarioP p m ()
-wallet customers seed passphrase =
- singleton (ResetWallet customers seed passphrase)
-
-existsTx :: ScenarioP p m TxI
-existsTx = singleton ExistsTx
-
-deposit :: TxI -> Customer -> Int -> ScenarioP p m UnspentI
-deposit tx customer value = singleton (Deposit tx customer value)
-
-deposit_ :: Monad m => TxI -> Customer -> Int -> ScenarioP p m ()
-deposit_ tx customer value = void $ deposit tx customer value
-
-spend :: TxI -> Address -> Int -> ScenarioP p m ()
-spend tx addr value = singleton (Spend tx addr value)
-
-withdrawal :: TxI -> UnspentI -> ScenarioP p m ()
-withdrawal tx unspent = singleton (Withdrawal tx unspent)
-
-block :: [TxI] -> ScenarioP p m BlockI
-block txs = singleton (CreateBlock txs)
-
-rollForward :: [BlockI] -> ScenarioP p m ()
-rollForward blocks = singleton (RollForward blocks)
-
-rollBackward :: Maybe BlockI -> ScenarioP p m ()
-rollBackward slot = singleton (RollBackward slot)
-
-historyByTime :: ScenarioP p m ByTime
-historyByTime = singleton HistoryByTime
-
-historyByCustomer :: ScenarioP p m ByCustomer
-historyByCustomer = singleton HistoryByCustomer
-
-newHistoryByTime :: ByTimeM ByTime -> ScenarioP p m ByTime
-newHistoryByTime = singleton . NewHistoryByTime
-
-availableBalance :: ScenarioP p m Int
-availableBalance = singleton AvailableBalance
-
-sign :: Tx -> Text -> ScenarioP p m Write.Tx
-sign tx pass = singleton (Sign tx pass)
-
-balance :: TxI -> ScenarioP p m Tx
-balance tx = singleton (Balance tx)
-
-utxo :: UnspentI -> ScenarioP p m UTxO
-utxo = singleton . UTxO
-
-assert :: p -> ScenarioP p m ()
-assert = singleton . Assert
-
-rollForwardBlocks
- :: LookupTimeFromSlot
- -> [BlockI]
- -> (WalletState, InterpreterState)
- -> (WalletState, InterpreterState)
-rollForwardBlocks timeOf blocks (w, interpreter@InterpreterState{..}) =
- ( w'
- , interpreter{iBlocks = newIBlocks, iBlockPoints = newIBlockPoints}
- )
- where
- w' = Wallet.rollForwardMany timeOf (NE.fromList blocks') w
- ((newIBlocks, newIBlockPoints), blocks') =
- mapAccumL
- rollForwardBlock
- (iBlocks, iBlockPoints)
- blocks
- rollForwardBlock (iBlocksCurrent, iBlockPointsCurrent) blockI =
- (
- ( Map.insert blockPoint newBlock iBlocksCurrent
- , Map.insert blockI blockPoint iBlockPointsCurrent
- )
- , EraValue newBlock
- )
- where
- txs = iBlockContents Map.! blockI
- newBlock = mockNextBlock startPoint txs
- blockPoint = getChainPoint newBlock
- startPoint =
- maybe GenesisPoint fst
- $ Map.lookupMax iBlocksCurrent
-
-rollBackwardBlock
- :: LookupTimeFromSlot
- -> Maybe BlockI
- -> (WalletState, InterpreterState)
- -> (WalletState, InterpreterState)
-rollBackwardBlock timeOf Nothing (w, interpreter) =
- ( fst $ Wallet.rollBackward timeOf GenesisPoint w
- , interpreter{iBlocks = mempty, iBlockPoints = mempty}
- )
-rollBackwardBlock timeOf (Just blockI) (w, interpreter@InterpreterState{..}) =
- case Map.lookup blockI iBlockPoints of
- Just keep ->
- ( w'
- , interpreter{iBlocks = newIBlocks, iBlockPoints = newIBlockPoints}
- )
- where
- w' = fst $ Wallet.rollBackward timeOf keep w
- newIBlocks = Map.takeWhileAntitone (<= keep) iBlocks
- newIBlockPoints = Map.filter (<= keep) iBlockPoints
- Nothing -> (w, interpreter)
-
-data InterpreterState = InterpreterState
- { iTxs :: Map TxI TxBody
- , iBlockContents :: Map BlockI [Tx]
- , iBlockPoints :: Map BlockI ChainPoint
- , iBlocks :: Map ChainPoint Block
- }
- deriving (Show)
-
-iTxsL :: Lens' InterpreterState (Map TxI TxBody)
-iTxsL = lens iTxs (\s x -> s{iTxs = x})
-
-iBlockContentsL :: Lens' InterpreterState (Map BlockI [Tx])
-iBlockContentsL = lens iBlockContents (\s x -> s{iBlockContents = x})
-
-iBlockPointsL :: Lens' InterpreterState (Map BlockI ChainPoint)
-iBlockPointsL = lens iBlockPoints (\s x -> s{iBlockPoints = x})
-
-newTxId :: Monad m => StateT InterpreterState m TxI
-newTxId = zoom iTxsL $ do
- txs <- get
- let z = maybe 0 fst $ Map.lookupMax txs
- txId = z + 1
- put $ Map.insert txId emptyTxBody txs
- return txId
-
-newBlockId :: Monad m => StateT InterpreterState m BlockI
-newBlockId = zoom iBlockContentsL $ do
- blocks <- get
- let z = maybe 0 fst $ Map.lookupMax blocks
- blockId = z + 1
- put $ Map.insert blockId [] blocks
- return blockId
-
-freshInterpreterState :: InterpreterState
-freshInterpreterState = InterpreterState mempty mempty mempty mempty
-
-unsafeCustomerAddress
- :: Wallet.WalletState -> Customer -> Write.Address
-unsafeCustomerAddress w = fromJust . flip Wallet.customerAddress w
-
-interpret
- :: (MonadIO m, MonadFail m)
- => WalletState
- -> (p -> m ())
- -> (Slot -> WithOrigin UTCTime)
- -> ScenarioP
- p
- (StateT (WalletState, InterpreterState) m)
- ()
- -> m ()
-interpret w runP slotTimes p = flip evalStateT w $ do
- walletState <- get
- (walletState', _) <-
- lift
- $ execStateT
- (go p)
- (walletState, freshInterpreterState)
- put walletState'
- where
- go = viewT >=> eval
- eval (ResetWallet customers seed passphrase :>>= k) = do
- Right mnemonics <- pure $ createMnemonicFromWords seed
- let new =
- Wallet.fromCredentialsAndGenesis
- (credentialsFromMnemonics mnemonics passphrase)
- (fromIntegral customers)
- Read.mockGenesisDataMainnet
- id .= (new, freshInterpreterState)
- go $ k ()
- eval (Return x) = return x
- eval (ExistsTx :>>= k) = do
- txId <- zoom _2 newTxId
- go $ k txId
- eval (Deposit tx customer value :>>= k) = do
- customerAddresses <- uses _1 unsafeCustomerAddress
- let v = mkAda $ fromIntegral value
- txOut = mkTxOut (customerAddresses customer) v
- Just txBody <- use (_2 . iTxsL . at tx)
- let (txBody', tix) = addTxOut txOut txBody
- _2 . iTxsL . ix tx .= txBody'
- go $ k $ UnspentI (tx, tix)
- eval (Withdrawal tx (UnspentI (tx', tix)) :>>= k) = do
- Just txId <- uses (_2 . iTxsL . at tx') $ fmap (getTxId . mkTx)
- _2 . iTxsL . ix tx %= \txBody -> addTxIn (TxIn txId tix) txBody
- go $ k ()
- eval (Spend tx address value :>>= k) = do
- Just txBody <- use (_2 . iTxsL . at tx)
- let (txBody', _tix) =
- addTxOut (mkTxOut address (mkAda $ fromIntegral value)) txBody
- _2 . iTxsL . ix tx .= txBody'
- go $ k ()
- eval (CreateBlock txs :>>= k) = do
- blockId <- zoom _2 newBlockId
- send <-
- uses (_2 . iTxsL)
- $ flip Map.restrictKeys
- $ Set.fromList txs
- _2 . iBlockContentsL . ix blockId .= (mkTx <$> Map.elems send)
- go $ k blockId
- eval (RollForward blocks :>>= k) = do
- modify $ rollForwardBlocks (fmap Just slotTimes) blocks
- go $ k ()
- eval (RollBackward blockKeep :>>= k) = do
- modify $ rollBackwardBlock (fmap Just slotTimes) blockKeep
- go $ k ()
- eval (HistoryByTime :>>= k) = do
- v <- uses _1 getTxHistoryByTime
- go $ k v
- eval (HistoryByCustomer :>>= k) = do
- v <- uses _1 Wallet.getTxHistoryByCustomer
- go $ k v
- eval (NewHistoryByTime m :>>= k) = do
- customerAddresses <- uses _1 unsafeCustomerAddress
- txIds' <- uses (_2 . iTxsL) $ (Map.!) . fmap (getTxId . mkTx)
- blockSlots <-
- uses (_2 . iBlockPointsL) $ (Map.!) . fmap slotFromChainPoint
- go
- $ k
- $ runReader m
- $ ByTimeMContext txIds' customerAddresses slotTimes blockSlots
- eval (AvailableBalance :>>= k) = do
- ValueC (CoinC v) _ <- uses _1 Wallet.availableBalance
- go $ k $ fromIntegral v
- eval (Sign tx pass :>>= k) = do
- Just stx <- uses _1 $ Wallet.signTx tx pass
- go $ k stx
- eval (Balance tx :>>= k) = do
- Just txBody <- use (_2 . iTxsL . at tx)
- ws <- use _1
- let etx =
- createPaymentTxBody
- (Read.EraValue Read.mockPParamsConway)
- (Time.toTimeTranslationPure Time.mockTimeInterpreter)
- txBody
- ws
- ResolvedTx btx _ <- case etx of
- Left e -> fail $ "createPaymentTxBody failed: " <> show e
- Right tx' -> return tx'
- go $ k btx
- eval (UTxO (UnspentI (tx, tix)) :>>= k) = do
- Just txBody <- use (_2 . iTxsL . at tx)
- let txId = getTxId $ mkTx txBody
- Just txOut <- pure $ txBody ^? txOutsL . ix tix
- go $ k $ Map.singleton (TxIn txId tix) txOut
- eval (Assert assertion :>>= k) = do
- lift $ runP assertion
- go $ k ()
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/ByTime.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/ByTime.hs
deleted file mode 100644
index f77db89bbcf..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/ByTime.hs
+++ /dev/null
@@ -1,244 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Use let" #-}
-
-module Cardano.Wallet.Deposit.Testing.DSL.ByTime
- ( -- * ByTime
- ByTimeM
- , ByTimeMContext (..)
- , ByTime
-
- -- * At time
- , atBlock
- , atSlot
- , newByTime
-
- -- * For customer
- , forCustomer
-
- -- * In tx
- , inTx
-
- -- * Value transfer
- , deposited
- , withdrawn
- , byCustomerFromByTime
- )
-where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.Map
- ( F
- , Map (..)
- , W
- , toFinger
- )
-import Cardano.Wallet.Deposit.Map.Timed
- ( Timed (..)
- )
-import Cardano.Wallet.Deposit.Pure
- ( Customer
- , ValueTransfer (received, spent)
- )
-import Cardano.Wallet.Deposit.Pure.API.TxHistory
- ( ByCustomer
- , ByTime
- , DownTime
- , firstJust
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- )
-import Cardano.Wallet.Deposit.Testing.DSL.Types
- ( BlockI
- , TxI
- )
-import Cardano.Wallet.Deposit.Write
- ( mkAda
- )
-import Cardano.Wallet.Read
- ( Slot
- , TxId
- , WithOrigin (..)
- )
-import Control.Monad.Reader
- ( Reader
- , asks
- )
-import Control.Monad.State
- ( State
- , StateT
- , execState
- , execStateT
- , modify'
- )
-import Control.Monad.Trans
- ( MonadTrans (..)
- )
-import Data.Foldable
- ( Foldable (..)
- )
-import Data.Map.Monoidal.Strict
- ( MonoidalMap
- )
-import Data.Monoid
- ( First
- )
-import Data.Ord
- ( Down (..)
- )
-import Data.Time
- ( UTCTime
- )
-
-import qualified Cardano.Wallet.Deposit.Map.Timed as TimedSeq
-import qualified Cardano.Wallet.Deposit.Map.Timed as TimeSeq
-import qualified Data.Map.Monoidal.Strict as MonoidalMap
-
-byCustomerFromByTime :: ByTime -> ByCustomer
-byCustomerFromByTime (Finger () xs) = Map () xs'
- where
- xs'
- :: MonoidalMap
- Customer
- (Map '[F (First Address) DownTime, W (First Slot) TxId] ValueTransfer)
- xs' = fold $ do
- Timed t (Map slot ys) <- TimeSeq.toList xs
- (customer, Map addr kv) <- MonoidalMap.toList ys
- pure
- $ MonoidalMap.singleton customer
- $ Finger addr
- $ TimedSeq.singleton (Timed t $ Map slot kv)
-
--- -------------------------------------------------------------------------------
--- -- AtTime
--- -------------------------------------------------------------------------------
-
-data ByTimeMContext = ByTimeMContext
- { txIdOfTxI :: TxI -> TxId
- , addrOfCustomer :: Customer -> Address
- , timeOfSlot :: Slot -> WithOrigin UTCTime
- , slotOfBlock :: BlockI -> Slot
- }
-
-type ByTimeM = Reader ByTimeMContext
-
-atBlock
- :: BlockI
- -> StateT
- (MonoidalMap Customer (Map '[W (First Address) TxId] ValueTransfer))
- ByTimeM
- ()
- -> StateT
- ( MonoidalMap
- DownTime
- (Map '[W (First Slot) Customer, W (First Address) TxId] ValueTransfer)
- )
- ByTimeM
- ()
-atBlock b v = do
- slotOf <- asks slotOfBlock
- atSlot (slotOf b) v
-
-atSlot
- :: Slot
- -> StateT
- (MonoidalMap Customer (Map '[W (First Address) TxId] ValueTransfer))
- ByTimeM
- ()
- -> StateT
- ( MonoidalMap
- DownTime
- (Map '[W (First Slot) Customer, W (First Address) TxId] ValueTransfer)
- )
- ByTimeM
- ()
-atSlot t v = do
- timeOf <- asks timeOfSlot
- txs <- lift $ newCustomers t v
- modify' $ MonoidalMap.insert (Down $ timeOf t) txs
-
-newByTime
- :: StateT
- ( MonoidalMap
- DownTime
- (Map '[W (First Slot) Customer, W (First Address) TxId] ValueTransfer)
- )
- ByTimeM
- ()
- -> ByTimeM ByTime
-newByTime v = toFinger . Map () <$> execStateT v mempty
-
--- -------------------------------------------------------------------------------
--- -- Customer
--- -------------------------------------------------------------------------------
-
-forCustomer
- :: Customer
- -> StateT
- (MonoidalMap TxId (Map '[] ValueTransfer))
- ByTimeM
- ()
- -> StateT
- (MonoidalMap Customer (Map '[W (First Address) TxId] ValueTransfer))
- ByTimeM
- ()
-forCustomer c v = do
- addrOf <- asks addrOfCustomer
- txs <- lift $ newTxIds (addrOf c) v
- modify' $ MonoidalMap.insert c txs
-
-newCustomers
- :: Slot
- -> StateT
- (MonoidalMap Customer (Map '[W (First Address) TxId] ValueTransfer))
- ByTimeM
- ()
- -> ByTimeM
- (Map '[W (First Slot) Customer, W (First Address) TxId] ValueTransfer)
-newCustomers slot v = Map (firstJust slot) <$> execStateT v mempty
-
--------------------------------------------------------------------------------
--- Tx
--------------------------------------------------------------------------------
-
-inTx
- :: TxI
- -> State ValueTransfer ()
- -> StateT
- (MonoidalMap TxId (Map '[] ValueTransfer))
- ByTimeM
- ()
-inTx tx v = do
- w <- pure $ newValueTransferP v
- txIdOf <- asks txIdOfTxI
- modify' $ MonoidalMap.insert (txIdOf tx) w
-
-newTxIds
- :: Address
- -> StateT
- (MonoidalMap TxId (Map '[] ValueTransfer))
- ByTimeM
- ()
- -> ByTimeM (Map '[W (First Address) TxId] ValueTransfer)
-newTxIds addr v = Map (firstJust addr) <$> execStateT v mempty
-
--------------------------------------------------------------------------------
--- Value transfer
--------------------------------------------------------------------------------
-
-deposited :: Int -> State ValueTransfer ()
-deposited n = modify' $ \s -> s{received = mkAda $ fromIntegral n}
-
-withdrawn :: Int -> State ValueTransfer ()
-withdrawn n = modify' $ \s -> s{spent = mkAda $ fromIntegral n}
-
-newValueTransferP
- :: State ValueTransfer ()
- -> Map '[] ValueTransfer
-newValueTransferP v = Value $ execState v mempty
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/Types.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/Types.hs
deleted file mode 100644
index 5ea04bbe213..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL/Types.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Cardano.Wallet.Deposit.Testing.DSL.Types where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.Read
- ( Ix
- )
-
-newtype TxI = TxI Int
- deriving (Eq, Ord, Show, Num)
-
-newtype UnspentI = UnspentI (TxI, Ix)
- deriving (Eq, Ord, Show)
-
-newtype BlockI = BlockI Int
- deriving (Eq, Ord, Show, Num)
-
-newtype TimeI = TimeI Int
- deriving (Eq, Ord, Show)
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs
deleted file mode 100644
index b47596e6b2b..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs
+++ /dev/null
@@ -1,148 +0,0 @@
-{-# LANGUAGE NumericUnderscores #-}
-
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Indirection module that re-exports types
--- related to computations involving Slots and wall-clock times.
---
--- TODO: Absorb this into a definition of 'TimeInterpreter'.
-module Cardano.Wallet.Deposit.Time
- ( -- * from Primitive
- TimeInterpreter
- , PastHorizonException
- , mockTimeInterpreter
-
- , slotToUTCTime
-
- -- * from Write
- , Write.TimeTranslation
- , toTimeTranslation
- , toTimeTranslationPure
-
- -- * wishlist
- , LookupTimeFromSlot
- , unsafeUTCTimeOfSlot
- , unsafeSlotOfUTCTime
- , systemStartMainnet
- , originTime
-
- ) where
-
-import Prelude
-
-import Cardano.Wallet.Primitive.Slotting
- ( PastHorizonException
- , StartTime (..)
- , hoistTimeInterpreter
- , interpretQuery
- , mkSingleEraInterpreter
- )
-import Cardano.Wallet.Primitive.Slotting.TimeTranslation
- ( toTimeTranslation
- , toTimeTranslationPure
- )
-import Cardano.Wallet.Primitive.Types.SlottingParameters
- ( ActiveSlotCoefficient (..)
- , EpochLength (..)
- , SlotLength (..)
- , SlottingParameters (..)
- )
-import Cardano.Wallet.Read
- ( Slot
- , SlotNo (..)
- , WithOrigin (..)
- )
-import Data.Functor.Identity
- ( Identity (..)
- )
-import Data.IntCast
- ( intCastMaybe
- )
-import Data.Quantity
- ( Quantity (..)
- )
-import Data.Time.Clock
- ( UTCTime (..)
- )
-import Data.Time.Clock.POSIX
- ( posixSecondsToUTCTime
- , utcTimeToPOSIXSeconds
- )
-
-import qualified Cardano.Wallet.Primitive.Slotting as Primitive
-import qualified Cardano.Wallet.Read as Read
-import qualified Cardano.Write.Tx as Write
-
-{-----------------------------------------------------------------------------
- TimeInterpreter
-------------------------------------------------------------------------------}
-type TimeInterpreter = Primitive.TimeInterpreter (Either PastHorizonException)
-
-mockTimeInterpreter :: Primitive.TimeInterpreter Identity
-mockTimeInterpreter = hoistTimeInterpreter (pure . runIdentity) $
- mkSingleEraInterpreter
- (StartTime $ UTCTime (toEnum 0) 0)
- mockSlottingParameters
-
-mockSlottingParameters :: SlottingParameters
-mockSlottingParameters = SlottingParameters
- { getSlotLength = SlotLength 1
- , getEpochLength = EpochLength 21_600
- , getActiveSlotCoefficient = ActiveSlotCoefficient 1
- , getSecurityParameter = Quantity 2_160
- }
-
-{-----------------------------------------------------------------------------
- TimeInterpreter
-------------------------------------------------------------------------------}
-
-type LookupTimeFromSlot = Slot -> Maybe (WithOrigin UTCTime)
-
--- | Look up the UTCTime corresponding to the start of the provided `Slot`.
---
--- TODO: Check roundtrip properties once we need to implement the corresponding 'utcTimeToSlot'.
-slotToUTCTime :: TimeInterpreter -> LookupTimeFromSlot
-slotToUTCTime _ti Origin = Just Origin
-slotToUTCTime ti (At s) = either (const Nothing) (Just . At) . interpretQuery ti . Primitive.slotToUTCTime =<< convertSlotNo s
- where
- convertSlotNo :: SlotNo -> Maybe Primitive.SlotNo
- convertSlotNo (SlotNo n) = Primitive.SlotNo <$> intCastMaybe n
-
--- TODO: Rename to mainnetUTCTimeOfSlot
--- TODO: Move to tests?
-unsafeUTCTimeOfSlot :: Slot -> Maybe (WithOrigin UTCTime)
-unsafeUTCTimeOfSlot Origin = Just Origin
-unsafeUTCTimeOfSlot (At (SlotNo n)) =
- Just . At
- $ posixSecondsToUTCTime
- $ fromIntegral pt
- where
- pts = fromIntegral n - byronSlots
- pt =
- if pts >= 0
- then shelleyTime + pts
- else shelleyTime + pts * 20
-
-unsafeSlotOfUTCTime :: UTCTime -> Read.Slot
-unsafeSlotOfUTCTime t
- | origin = Origin
- | byron = At $ SlotNo $ fromIntegral $ (pt - originTime) `div` 20
- | otherwise = At $ SlotNo $ fromIntegral $ pt - shelleyTime + byronSlots
- where
- pt = floor $ utcTimeToPOSIXSeconds t
- origin = pt < originTime
- byron = pt < shelleyTime
-
-byronSlots :: Integer
-byronSlots = 4_924_800
-
-shelleyTime :: Integer
-shelleyTime = 1_596_491_091
-
-originTime :: Integer
-originTime = shelleyTime - byronSlots * 20
-
-systemStartMainnet :: UTCTime
-systemStartMainnet = posixSecondsToUTCTime $ fromIntegral originTime
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs
deleted file mode 100644
index 9d9784b3bf3..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs
+++ /dev/null
@@ -1,222 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-
--- | 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
- ( -- * Basic types
- Address
- , Value
- , TxId
- , Tx
- , Block
- , mkTx
- , TxBody (..)
- , TxIn
- , TxOut
- , Coin
-
- -- * Transaction balancing
- , Write.IsRecentEra
- , Write.Conway
- , L.PParams
- , Write.UTxOAssumptions (..)
- , Write.ChangeAddressGen (..)
- , Write.StakeKeyDepositLookup (..)
- , Write.TimelockKeyWitnessCounts (..)
- , Write.UTxOIndex
- , Write.constructUTxOIndex
- , Write.UTxO
- , toConwayUTxO
- , Write.PartialTx (..)
- , Write.ErrBalanceTx (..)
- , Write.ErrBalanceTxAssetsInsufficientError (..)
- , Write.ErrBalanceTxInsufficientCollateralError (..)
- , Write.ErrBalanceTxInternalError (..)
- , Write.ErrBalanceTxOutputError (..)
- , Write.ErrBalanceTxOutputErrorInfo (..)
- , Write.ErrBalanceTxUnableToCreateChangeError (..)
- , Write.ErrAssignRedeemers (..)
- , Write.balanceTx
-
- -- * Signing
- , addSignature
-
- -- ** Time interpreter
- , Write.TimeTranslation
-
- -- * Helper functions
- , mkAda
- , mkTxOut
- , txOutsL
- , toConwayTx
- , addTxIn
- , addTxOut
- , emptyTxBody
- , UTxO.resolvedTx
- , UTxO.resolvedInputs
- ) where
-
-import Prelude
-
-import Cardano.Ledger.Coin
- ( Coin
- )
-import Cardano.Read.Ledger.Tx.Output
- ( Output (..)
- )
-import Cardano.Wallet.Address.BIP32_Ed25519
- ( XPrv
- , sign
- , toXPub
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- , Ix
- , SlotNo (..)
- , TxId
- , TxIn
- , TxOut
- , Value
- )
-import Cardano.Wallet.Deposit.Write.Keys
- ( signedDSIGNfromXSignature
- , vkeyFromXPub
- )
-import Cardano.Wallet.Read.Tx
- ( toConwayOutput
- )
-import Control.Lens
- ( Lens'
- , lens
- , (%~)
- , (&)
- , (.~)
- )
-import Data.Map
- ( Map
- )
-import Data.Maybe.Strict
- ( StrictMaybe (..)
- , maybeToStrictMaybe
- )
-import Data.Sequence.Strict
- ( StrictSeq
- , fromList
- )
-import Data.Set
- ( Set
- )
-
-import qualified Cardano.Ledger.Api as L
-import qualified Cardano.Ledger.Api.Tx.In as L
-import qualified Cardano.Ledger.Slot as L
-import qualified Cardano.Wallet.Deposit.Pure.UTxO.Tx as UTxO
-import qualified Cardano.Wallet.Read as Read
-import qualified Cardano.Wallet.Read.Hash as Hash
-import qualified Cardano.Write.Eras as Write
-import qualified Cardano.Write.Tx as Write
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-
-{-----------------------------------------------------------------------------
- Types
-------------------------------------------------------------------------------}
-type Tx = Read.Tx Read.Conway
-
-type Block = Read.Block Read.Conway
-
-{-----------------------------------------------------------------------------
- Signing
-------------------------------------------------------------------------------}
--- | Add a signature to the transaction using the private key
-addSignature :: XPrv -> Tx -> Tx
-addSignature xprv tx@(Read.Tx ledgerTx) =
- Read.Tx
- (ledgerTx & (L.witsTxL . L.addrTxWitsL) %~ Set.insert witnessVKey)
- where
- txHash = Read.hashFromTxId $ Read.getTxId tx
- xpub = toXPub xprv
- xsign = sign xprv (Hash.hashToBytes txHash)
- witnessVKey =
- L.WitVKey (vkeyFromXPub xpub) (signedDSIGNfromXSignature xsign)
-
-{-----------------------------------------------------------------------------
- Convenience TxBody
-------------------------------------------------------------------------------}
-
-data TxBody = TxBody
- { spendInputs :: Set TxIn
- , collInputs :: Set TxIn
- , txouts :: Map Ix TxOut
- , collRet :: Maybe TxOut
- , expirySlot :: Maybe SlotNo
- }
- deriving (Show)
-
-txOutsL :: Lens' TxBody (Map Ix TxOut)
-txOutsL = lens txouts (\s a -> s{txouts = a})
-
-nextIx :: TxBody -> Ix
-nextIx = maybe minBound (succ . fst) . Map.lookupMax . txouts
-
-addTxOut :: TxOut -> TxBody -> (TxBody, Ix)
-addTxOut txout txbody = (txBody', txIx)
- where
- txBody' = txbody & txOutsL .~ Map.insert txIx txout (txouts txbody)
- txIx = nextIx txbody
-
-addTxIn :: TxIn -> TxBody -> TxBody
-addTxIn txin txbody = txbody{spendInputs = Set.insert txin (spendInputs txbody)}
-
-emptyTxBody :: TxBody
-emptyTxBody = TxBody mempty mempty mempty Nothing Nothing
-
--- | Inject a number of ADA, i.e. a million lovelace.
-mkAda :: Integer -> Value
-mkAda = Read.injectCoin . Read.CoinC . (* 1000000)
-
-mkTxOut :: Address -> Value -> TxOut
-mkTxOut = Read.mkBasicTxOut
-
-toConwayTx :: Tx -> Read.Tx Read.Conway
-toConwayTx = id
-
-mkTx :: TxBody -> Tx
-mkTx txbody = Read.Tx $ L.mkBasicTx txBody
- where
- txBody :: L.TxBody L.Conway
- txBody =
- L.mkBasicTxBody
- & L.inputsTxBodyL .~ Set.map toLedgerTxIn (spendInputs txbody)
- & L.collateralInputsTxBodyL
- .~ Set.map toLedgerTxIn (collInputs txbody)
- & L.outputsTxBodyL .~ toLedgerTxOuts (txouts txbody)
- & L.collateralReturnTxBodyL
- .~ toLedgerMaybeTxOut (collRet txbody)
- & L.vldtTxBodyL
- .~ L.ValidityInterval
- SNothing
- (toLedgerSlotNo <$> maybeToStrictMaybe (expirySlot txbody))
-
-toLedgerSlotNo :: SlotNo -> L.SlotNo
-toLedgerSlotNo (SlotNo n) = L.SlotNo (fromInteger $ fromIntegral n)
-
-toLedgerTxIn :: TxIn -> L.TxIn L.StandardCrypto
-toLedgerTxIn = id
-
-toLedgerTxOuts :: Map Ix TxOut -> StrictSeq (L.TxOut L.Conway)
-toLedgerTxOuts = fromList . map (toConwayTxOut . snd) . Map.toAscList
-
-toLedgerMaybeTxOut :: Maybe TxOut -> StrictMaybe (L.TxOut L.Conway)
-toLedgerMaybeTxOut = fmap toConwayTxOut . maybeToStrictMaybe
-
-toConwayTxOut :: TxOut -> L.TxOut L.Conway
-toConwayTxOut txout =
- case toConwayOutput txout of
- Output o -> o
-
-toConwayUTxO :: Map TxIn TxOut -> Write.UTxO L.Conway
-toConwayUTxO = Write.UTxO . Map.map toConwayTxOut
diff --git a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write/Keys.hs b/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write/Keys.hs
deleted file mode 100644
index 2fa7c1c413e..00000000000
--- a/lib/deposit-wallet/src/Cardano/Wallet/Deposit/Write/Keys.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-
--- | Module for converting key types from
--- @Cardano.Ledger@ with key types from @Cardano.Crypto.Wallet@.
---
--- TODO: Match this up with the @Write@ hierarchy.
-module Cardano.Wallet.Deposit.Write.Keys
- ( enterpriseAddressFromVKey
- , vkeyFromXPub
- , signedDSIGNfromXSignature
- ) where
-
-import Prelude
-
-import Cardano.Crypto.Wallet
- ( xpubPublicKey
- )
-import Cardano.Ledger.Keys
- ( SignedDSIGN
- , VKey (..)
- )
-import Cardano.Wallet.Address.BIP32_Ed25519
- ( XPub
- , XSignature
- , rawSerialiseXSignature
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- )
-import Data.Maybe
- ( fromMaybe
- )
-
-import qualified Cardano.Crypto.DSIGN as DSIGN
-import qualified Cardano.Ledger.Address as L
-import qualified Cardano.Ledger.Api as L
-import qualified Cardano.Ledger.BaseTypes as L
-import qualified Cardano.Ledger.Credential as L
-import qualified Cardano.Ledger.Hashes as L
-import qualified Cardano.Ledger.Keys as L
-
-{-----------------------------------------------------------------------------
- Key conversion
-------------------------------------------------------------------------------}
--- | Create an enterprise address from a ledger 'VKey'.
-enterpriseAddressFromVKey
- :: L.Network
- -> VKey 'L.Witness L.StandardCrypto
- -> Address
-enterpriseAddressFromVKey network =
- mkEnterpriseAddress
- . L.coerceKeyRole
- . L.hashKey
- where
- mkEnterpriseAddress h =
- L.compactAddr
- $ L.Addr network (L.KeyHashObj h) L.StakeRefNull
-
--- | Convert 'XPub' to a ledger verification key.
-vkeyFromXPub :: XPub -> VKey 'L.Witness L.StandardCrypto
-vkeyFromXPub =
- VKey
- . fromMaybe impossible
- . DSIGN.rawDeserialiseVerKeyDSIGN
- . xpubPublicKey
- where
- impossible = error "impossible: Cannot convert XPub to VKey"
-
--- | Convert 'XSignature' to a ledger signature.
-signedDSIGNfromXSignature
- :: XSignature
- -> SignedDSIGN L.StandardCrypto
- (L.Hash L.StandardCrypto L.EraIndependentTxBody)
-signedDSIGNfromXSignature =
- DSIGN.SignedDSIGN
- . fromMaybe impossible
- . DSIGN.rawDeserialiseSigDSIGN
- . rawSerialiseXSignature
- where
- impossible = error "impossible: Cannot convert XSignature to SignedDSIGN"
diff --git a/lib/deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs b/lib/deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs
deleted file mode 100644
index 821f04bbec4..00000000000
--- a/lib/deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs
+++ /dev/null
@@ -1,144 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE RecordWildCards #-}
-
-{-|
-Copyright: © 2024 Cardano Foundation
-License: Apache-2.0
-
-Mock implementation of a blockchain for the purpose of testing.
-
-TODO:
-* Make the blockchain more real.
--}
-module Test.Scenario.Blockchain
- ( assert
-
- , ScenarioEnv
- , withScenarioEnvMock
- , withWalletEnvMock
-
- , Faucet
- , ada
- , payFromFaucet
-
- , signTx
- , submitTx
- ) where
-
-import Prelude
-
-import Cardano.Crypto.Wallet
- ( XPrv
- )
-import Cardano.Wallet.Deposit.IO.Network.Mock
- ( newNetworkEnvMock
- )
-import Cardano.Wallet.Deposit.IO.Network.Type
- ( NetworkEnv (..)
- , mapBlock
- )
-import Cardano.Wallet.Deposit.Pure
- ( BIP32Path
- )
-import Control.Concurrent
- ( threadDelay
- )
-import Control.Tracer
- ( nullTracer
- )
-import Data.Store
- ( newStore
- )
-import GHC.Stack
- ( HasCallStack
- )
-
-import qualified Cardano.Wallet.Deposit.IO as Wallet
-import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Cardano.Wallet.Deposit.Write as Write
-import qualified Data.Map.Strict as Map
-
-{-----------------------------------------------------------------------------
- Logic
-------------------------------------------------------------------------------}
-
-assert :: HasCallStack => Bool -> IO ()
-assert True = pure ()
-assert False = error "Assertion failed!"
-
-{-----------------------------------------------------------------------------
- Environment
-------------------------------------------------------------------------------}
--- | Environment for scenarios.
-data ScenarioEnv = ScenarioEnv
- { genesisData :: Read.GenesisData
- , networkEnv :: NetworkEnv IO (Read.EraValue Read.Block)
- , faucet :: Faucet
- }
-
--- | Acquire and release a mock environment for a blockchain
-withScenarioEnvMock :: (ScenarioEnv -> IO a) -> IO a
-withScenarioEnvMock action = do
- networkEnv <- mapBlock Read.EraValue <$> newNetworkEnvMock
- action
- $ ScenarioEnv
- { genesisData = Read.mockGenesisDataMainnet
- , networkEnv
- , faucet = Faucet{xprv = error "TODO: Faucet xprv"}
- }
-
--- | Acquire and release a mock environment for a wallet.
-withWalletEnvMock
- :: ScenarioEnv
- -> (Wallet.WalletEnv IO -> IO a)
- -> IO a
-withWalletEnvMock ScenarioEnv{..} action = do
- database <- newStore
- let walletEnv = Wallet.WalletEnv
- Wallet.WalletBootEnv
- { Wallet.logger = nullTracer
- , Wallet.genesisData = genesisData
- , Wallet.networkEnv = networkEnv
- }
- database
- action walletEnv
-
-{-----------------------------------------------------------------------------
- Faucet
-------------------------------------------------------------------------------}
-newtype Faucet = Faucet
- { xprv :: XPrv
- }
-
-ada :: Integer -> Write.Value
-ada = Write.mkAda
-
-payFromFaucet :: ScenarioEnv -> [(Write.Address, Write.Value)] -> IO ()
-payFromFaucet env destinations =
- submitTx env tx
- where
- toTxOut (addr, value) = Write.mkTxOut addr value
- txBody = Write.TxBody
- { Write.spendInputs = mempty
- , Write.collInputs = mempty
- , Write.txouts =
- Map.fromList $ zip [toEnum 0..] $ map toTxOut destinations
- , Write.collRet = Nothing
- , Write.expirySlot = Nothing
- }
- tx = signTx (xprv (faucet env)) [] $ Write.mkTx txBody
-
-{-----------------------------------------------------------------------------
- Transaction submission
-------------------------------------------------------------------------------}
-
-signTx :: XPrv -> [BIP32Path] -> Write.Tx -> Write.Tx
-signTx _ _ = id
-
-submitTx :: ScenarioEnv -> Write.Tx -> IO ()
-submitTx env tx = do
- _ <- postTx (networkEnv env) tx
-
- -- Wait a short while to give the tx time to make it on-chain.
- threadDelay 500_000
diff --git a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs b/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs
deleted file mode 120000
index daac8bef83a..00000000000
--- a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs
+++ /dev/null
@@ -1 +0,0 @@
-Exchanges.lhs.md
\ No newline at end of file
diff --git a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md b/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md
deleted file mode 100644
index 1d22927004d..00000000000
--- a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md
+++ /dev/null
@@ -1,229 +0,0 @@
-# Use case: Centralized Exchange
-
-This document describes how a centralized exchange (CEX) can use the Deposit Wallet to
-
-1. Assign an address to a customer ID.
-2. Track deposits at this address.
-3. Track deposits at all addresses.
-4. Create payments to a different wallet.
-
-# Scenarios, Haskell
-
-In this section, we describe the scenarios using Haskell.
-
-```haskell
-module Test.Scenario.Wallet.Deposit.Exchanges
- ( scenarioRestore
- , scenarioStart
- , scenarioCreateAddressList
- , scenarioTrackDepositOne
- , scenarioTrackDepositAll
- , scenarioCreatePayment
- ) where
-
-import Prelude
-
-import Cardano.Crypto.Wallet
- ( XPrv
- , XPub
- )
-import Cardano.Wallet.Deposit.IO
- ( WalletEnv
- , WalletInstance
- )
-import Cardano.Wallet.Deposit.Pure
- ( Customer
- , ValueTransfer (..)
- , Credentials (..)
- , ResolvedTx (..)
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- , Value
- , TxId
- , lessOrEqual
- )
-import Control.Tracer
- ( nullTracer
- )
-import Test.Scenario.Blockchain
- ( ScenarioEnv
- , ada
- , assert
- , payFromFaucet
- , signTx
- , submitTx
- )
-
-import qualified Cardano.Wallet.Deposit.IO as Wallet
-import qualified Data.Map as Map
-```
-
-We use a function `depositFundsAt` to make a deposit at a given address.
-
-```haskell
-depositFundsAt :: ScenarioEnv -> Address -> Value -> IO ()
-depositFundsAt env address value = payFromFaucet env [(address, value)]
-```
-
-We ignore the mapping from TxId when retrieving the customer history
-```haskell
-getCustomerDeposits :: Customer -> WalletInstance -> IO [(TxId, ValueTransfer)]
-getCustomerDeposits customer w =
- Map.toList <$> Wallet.getCustomerDeposits w customer Nothing
-```
-
-## 0. Start a Wallet
-
-A `WalletInstance` denotes a mutable wallet that is actively synchronizing to the blockchain, continuously writes its state to a database file, and responds to queries.
-
-In order to create a fresh wallet, or in order to restore a wallet from its public key all the way from genesis, use the function `withWalletInit`. In addition to the public key, this function expects a number which equals the numerically largest customer ID previously handled with this wallet.
-
-```haskell
-scenarioRestore
- :: XPub -> WalletEnv IO -> IO ()
-scenarioRestore xpub env = do
- let knownCustomerCount = 127
- Wallet.withWalletInit nullTracer env (XPubCredentials xpub) knownCustomerCount $ \w -> do
- value <- Wallet.availableBalance w
- assert $ value == ada 0
-```
-
-In order to load the wallet state from a database file and resume operation from that state use the function `withWalletLoad`.
-
-```haskell
-scenarioStart
- :: WalletEnv IO -> IO ()
-scenarioStart env =
- Wallet.withWalletLoad nullTracer env $ \w -> do
- value <- Wallet.availableBalance w
- assert $ value == ada 0
-```
-
-## 1. Assign an address to a customer ID
-
-A `Customer` is represented by a numeric customer ID.
-Given such a customer ID, the function `customerAddress` will create an address and add the association between the customer and this address to the wallet state.
-
-(The mapping from customer ID to address is deterministic and based on the [BIP-32][] address derivation scheme.)
-
- [bip-32]: https://github.com/bitcoin/bips/blob/master/bip-0032.mediawiki
-
-
-The function `listCustomers` returns the associations between customers and addresses recorded in the current wallet state.
-
-```haskell
-scenarioCreateAddressList
- :: WalletInstance -> IO ()
-scenarioCreateAddressList w = do
- let customer = 31
- Just address <- Wallet.customerAddress customer w
- customers <- Wallet.listCustomers w
- assert $ (customer, address) `elem` customers
-```
-
-## 2. Track deposits at this address
-
-As soon as an association between customer and address has been added to the wallet state using `customerAddress`, the wallet will track deposits sent to this address.
-
-The function `getCustomerDeposits` returns a summary for each transaction that is related to this customer. For every summary, the `received` field records the total deposit made by the customer at this address in this transaction.
-
-(The `spent` field has informative purpose only, and records whether the wallet has moved any funds out of this address.)
-
-The following scenario illustrates how `getCustomerDeposits` records deposits:
-
-```haskell
-scenarioTrackDepositOne
- :: ScenarioEnv -> WalletInstance -> IO ()
-scenarioTrackDepositOne env w = do
- Just address <- Wallet.customerAddress customer w
-
- -- no deposits
- txsummaries0 <- getCustomerDeposits customer w
- assert $ null txsummaries0
-
- -- first deposit
- depositFundsAt env address coin
- txsummaries1 <- getCustomerDeposits customer w
- assert $ map (received . snd) txsummaries1 == [coin]
-
- -- second deposit
- depositFundsAt env address coin
- txsummaries2 <- getCustomerDeposits customer w
- assert $ map (received . snd) txsummaries2 == [coin, coin]
- where
- customer = 7 :: Customer
- coin = ada 12
-```
-
-## 3. Track deposits at all addresses
-
-A centralized exchange typically wants to monitor all transactions in a recent time window for activity in order to synchronize customer deposits on the blockchain ledger with the exchange ledger recording customer balances.
-
-This is a task for the `getCustomerHistories` function — it returns a mapping from customers to `TxSummaries` that record the entire activity within the given time interval.
-
-The time interval is specified by a `from` and a `to` point on the blockchain. We note that the `from` argument is exclusive while the `to` argument is inclusive.
-We use the type `ChainPoint` to specify points on the blockchain — this type uses both a slot number and a block header to uniquely identify a block. We do this in order to allow atomic operations — in the event that the `to` or `from` point are no longer part of the consensus chain, the `getCustomerHistories` functions throws an exception.
-
-The wallet is synchronized to a particular point on the blockchain — use `getWalletTip` to query it.
-
-```haskell
-scenarioTrackDepositAll
- :: ScenarioEnv -> WalletInstance -> IO ()
-scenarioTrackDepositAll env w = do
- Just address1 <- Wallet.customerAddress customer1 w
- Just address2 <- Wallet.customerAddress customer2 w
-
- depositFundsAt env address1 coin
- depositFundsAt env address2 coin
- depositFundsAt env address1 (coin <> coin)
-
- history <- Wallet.getAllDeposits w Nothing
- assert $
- Map.map received history
- ==
- Map.fromList
- [ (customer1, coin <> coin <> coin)
- , (customer2, coin)
- ]
- where
- customer1, customer2 :: Customer
- customer1 = 1
- customer2 = 2
- coin = ada 3
-```
-
-## 4. Create payments to a different wallet
-
-The `createPayment` function allows you to move funds from one wallet to other addresses, e.g. in order to process customer withdrawals. If the wallet has sufficient funds, this function creates a transaction body which sends the given values to the given addresses.
-
-The transaction body needs to be signed. Given a transaction body, the function `getBIP32PathsForOwnedInputs` will provide you with all [BIP-32][] address derivation paths of all inputs that are owned by the wallet, and which therefore require a signature.
-
-```haskell
-scenarioCreatePayment
- :: XPrv -> ScenarioEnv -> Address -> WalletInstance -> IO ()
-scenarioCreatePayment xprv env destination w = do
- -- deposit some funds at customer address
- Just address1 <- Wallet.customerAddress customer w
- depositFundsAt env address1 (coin <> coin)
- value1 <- Wallet.availableBalance w
- assert $ value1 == (coin <> coin)
-
- -- createPayment
- Right (ResolvedTx txUnsigned _) <- Wallet.createPayment [(destination, coin)] w
- paths <- Wallet.getBIP32PathsForOwnedInputs txUnsigned w
- let tx = signTx xprv paths txUnsigned
- submitTx env tx
-
- -- funds have been moved out of the wallet
- value2 <- Wallet.availableBalance w
- assert $ (value2 <> coin) `lessOrEqual` value1
-
- -- but the original deposit amount is still recorded
- txsummaries <- getCustomerDeposits customer w
- assert $ value1 `elem` map (received . snd) txsummaries
- where
- customer :: Customer
- customer = 17
- coin = ada 5
-```
diff --git a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs b/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs
deleted file mode 100644
index ea0e8193178..00000000000
--- a/lib/deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs
+++ /dev/null
@@ -1,118 +0,0 @@
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Execute usage scenarios for the deposit wallet.
-module Test.Scenario.Wallet.Deposit.Run
- ( main
- ) where
-
-import Prelude
-
-import Cardano.Crypto.Wallet
- ( XPrv
- , XPub
- , generate
- , toXPub
- )
-import Cardano.Wallet.Deposit.Pure.State.Creation
- ( Credentials (..)
- )
-import Control.Tracer
- ( nullTracer
- )
-import Test.Hspec
- ( SpecWith
- , describe
- , it
- )
-import Test.Hspec.Extra
- ( aroundAll
- , hspecMain
- )
-import Test.Scenario.Blockchain
- ( ScenarioEnv
- , ada
- , assert
- , payFromFaucet
- , withScenarioEnvMock
- , withWalletEnvMock
- )
-
-import qualified Cardano.Wallet.Deposit.IO as Wallet
-import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Data.ByteString.Char8 as B8
-import qualified Data.ByteString.Short as SBS
-import qualified Test.Scenario.Wallet.Deposit.Exchanges as Exchanges
-
-main :: IO ()
-main =
- hspecMain
- $ aroundAll withScenarioEnvMock scenarios
-
-scenarios :: SpecWith ScenarioEnv
-scenarios = do
- describe "Scenarios for centralized exchanges" $ do
- it "0. Restore a wallet" $ \env ->
- withWalletEnvMock env
- $ Exchanges.scenarioRestore xpub
-
- it "0. Start a wallet" $ \env ->
- withWalletEnvMock env $ \w -> do
- Exchanges.scenarioRestore xpub w
- Exchanges.scenarioStart w
-
- it "1. Assign an address to a customer ID" $ \env -> do
- withWalletEnvMock env $ \walletEnv ->
- Wallet.withWalletInit
- nullTracer
- walletEnv
- (XPubCredentials $ freshXPub 1)
- 32
- Exchanges.scenarioCreateAddressList
-
- it "4. Create payments to a different wallet" $ \env -> do
- withWalletEnvMock env $ \walletEnv ->
- Wallet.withWalletInit nullTracer
- walletEnv (XPubCredentials xpub) 32
- $ Exchanges.scenarioCreatePayment xprv env mockAddress
-
- describe "Temporary tests" $ do
- it "Wallet receives funds that are sent to customer address" $ \env -> do
- withWalletEnvMock env $ \walletEnv ->
- Wallet.withWalletInit
- nullTracer
- walletEnv
- (XPubCredentials $ freshXPub 0)
- 8
- $ testBalance env
-
-xpub :: XPub
-xpub = toXPub xprv
-
-xprv :: XPrv
-xprv = generate (B8.pack "random seed for a testing xpub lala") B8.empty
-
-freshXPub :: Integer -> XPub
-freshXPub i =
- toXPub
- $ generate
- (B8.pack $ "random seed for a testing xpub lala" <> show i)
- B8.empty
-
-mockAddress :: Read.Address
-mockAddress =
- Read.mkEnterpriseAddress
- Read.MainnetTag
- (SBS.pack $ replicate 32 0)
-
-testBalance
- :: ScenarioEnv -> Wallet.WalletInstance -> IO ()
-testBalance env w = do
- Just address <- Wallet.customerAddress customer w
- payFromFaucet env [(address, coin)]
- value <- Wallet.availableBalance w
- assert $ coin == value
- where
- customer = 7
- coin = ada 12
diff --git a/lib/deposit-wallet/test/scenario/test-suite-scenario.hs b/lib/deposit-wallet/test/scenario/test-suite-scenario.hs
deleted file mode 100644
index 9c2e55cbedf..00000000000
--- a/lib/deposit-wallet/test/scenario/test-suite-scenario.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Main where
-
-import Prelude
-
-import qualified Test.Scenario.Wallet.Deposit.Run
- ( main
- )
-
-main :: IO ()
-main = Test.Scenario.Wallet.Deposit.Run.main
diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/JSON/JSONSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/JSON/JSONSpec.hs
deleted file mode 100644
index 56371cb0951..00000000000
--- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/JSON/JSONSpec.hs
+++ /dev/null
@@ -1,186 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeApplications #-}
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Cardano.Wallet.Deposit.HTTP.JSON.JSONSpec
- ( spec
- ) where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.HTTP.Types.JSON
- ( Address
- , ApiT (..)
- , ChainPoint (..)
- , Customer
- , CustomerList
- )
-import Cardano.Wallet.Deposit.HTTP.Types.OpenAPI
- ( addressSchema
- , chainPointSchema
- , customerListSchema
- , customerSchema
- , depositDefinitions
- )
-import Cardano.Wallet.Deposit.Pure
- ( Word31
- , fromRawCustomer
- )
-import Cardano.Wallet.Deposit.Read
- ( NetworkTag (MainnetTag, TestnetTag)
- , mkEnterpriseAddress
- )
-import Data.Aeson
- ( FromJSON (..)
- , ToJSON (..)
- , Value
- , decode
- , encode
- )
-import Data.Aeson.Encode.Pretty
- ( encodePretty
- )
-import Data.OpenApi
- ( Definitions
- , Schema
- , validateJSON
- )
-import Data.Word
- ( Word64
- )
-import Test.Hspec
- ( Expectation
- , Spec
- , describe
- , it
- , shouldBe
- )
-import Test.QuickCheck
- ( Arbitrary (..)
- , Gen
- , Property
- , Testable
- , arbitrarySizedBoundedIntegral
- , chooseInt
- , counterexample
- , elements
- , forAll
- , frequency
- , property
- , shrinkIntegral
- , vectorOf
- , (===)
- )
-
-import qualified Cardano.Wallet.Read as Read
-import qualified Data.ByteString.Lazy.Char8 as BL
-import qualified Data.ByteString.Short as SBS
-import qualified Data.List as L
-
-spec :: Spec
-spec = do
- describe "JSON serialization & deserialization" $ do
- it "ApiT Address" $ property $
- prop_jsonRoundtrip @(ApiT Address)
- it "ApiT Customer" $ property $
- prop_jsonRoundtrip @(ApiT Customer)
- it "ApiT CustomerList" $ property $
- prop_jsonRoundtrip @(ApiT CustomerList)
- it "ApiT ChainPoint" $ property $
- prop_jsonRoundtrip @(ApiT ChainPoint)
- describe "schema checks" $ do
- it "ApiT Address"
- $ jsonMatchesSchema genApiTAddress depositDefinitions addressSchema
- it "ApiT Customer"
- $ jsonMatchesSchema genApiTCustomer depositDefinitions customerSchema
- it "ApiT CustomerList"
- $ jsonMatchesSchema genApiTCustomerList depositDefinitions customerListSchema
- it "ApiT ChainPoint"
- $ jsonMatchesSchema genApiTChainPoint depositDefinitions chainPointSchema
-
-jsonMatchesSchema
- :: (ToJSON a, Show a)
- => Gen a
- -> Definitions Schema
- -> Schema
- -> Property
-jsonMatchesSchema gen defs schema =
- forAll gen
- $ counterExampleJSON "validate"
- $ validateInstance defs schema
- where
- validate :: Definitions Schema -> Schema -> Value -> Expectation
- validate defs' sch' x = validateJSON defs' sch' x `shouldBe` []
-
- validateInstance :: ToJSON a => Definitions Schema -> Schema -> a -> Expectation
- validateInstance defs' sch' = validate defs' sch' . toJSON
-
- counterExampleJSON
- :: (Testable prop, ToJSON a)
- => String
- -> (a -> prop)
- -> a
- -> Property
- counterExampleJSON t f x =
- counterexample
- ("Failed to " <> t <> ":\n" <> BL.unpack (encodePretty $ toJSON x))
- $ f x
-
-prop_jsonRoundtrip :: (Eq a, Show a, FromJSON a, ToJSON a) => a -> Property
-prop_jsonRoundtrip val =
- decode (encode val) === Just val
-
-genAddress :: Gen Address
-genAddress = do
- network <- elements [MainnetTag, TestnetTag]
- keyhashCred <- SBS.pack <$> vectorOf 28 arbitrary
- pure $ mkEnterpriseAddress network keyhashCred
-
-genApiTAddress :: Gen (ApiT Address)
-genApiTAddress = ApiT <$> genAddress
-
-genApiTCustomer :: Gen (ApiT Customer)
-genApiTCustomer =
- ApiT . fromRawCustomer <$> arbitrary
-
-genApiTCustomerList :: Gen (ApiT CustomerList)
-genApiTCustomerList = do
- listLen <- chooseInt (0, 100)
- let genPair = (,) <$> (unApiT <$> arbitrary) <*> (unApiT <$> arbitrary)
- vectors <- vectorOf listLen genPair
- let uniqueCustomer = L.nubBy (\a b -> fst a == fst b)
- let uniqueAddr = L.nubBy (\a b -> snd a == snd b)
- pure $ ApiT $ uniqueAddr $ uniqueCustomer vectors
-
-genApiTChainPoint :: Gen (ApiT ChainPoint)
-genApiTChainPoint = ApiT <$> genChainPoint
-
-genChainPoint :: Gen Read.ChainPoint
-genChainPoint = frequency
- [ ( 1, pure Read.GenesisPoint)
- , (40, Read.BlockPoint <$> genReadSlotNo <*> genHeaderHash)
- ]
- where
- genReadSlotNo = Read.SlotNo . fromIntegral <$> (arbitrary :: Gen Word64)
- genHeaderHash = elements mockHashes
-
-mockHashes :: [Read.RawHeaderHash]
-mockHashes = map Read.mockRawHeaderHash [0..2]
-
-instance Arbitrary (ApiT Address) where
- arbitrary = genApiTAddress
-
-instance Arbitrary (ApiT Customer) where
- arbitrary = genApiTCustomer
-
-instance Arbitrary (ApiT CustomerList) where
- arbitrary = genApiTCustomerList
-
-instance Arbitrary (ApiT ChainPoint) where
- arbitrary = genApiTChainPoint
-
-instance Arbitrary Word31 where
- arbitrary = arbitrarySizedBoundedIntegral
- shrink = shrinkIntegral
diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/OpenAPISpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/OpenAPISpec.hs
deleted file mode 100644
index bb9d4c0e73e..00000000000
--- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/HTTP/OpenAPISpec.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-module Cardano.Wallet.Deposit.HTTP.OpenAPISpec
- ( spec
- ) where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.HTTP.Types.OpenAPI
- ( generateOpenapi3
- )
-import Paths_cardano_deposit_wallet
- ( getDataDir
- , getDataFileName
- )
-import System.Directory
- ( doesDirectoryExist
- , doesFileExist
- )
-import Test.Hspec
- ( Spec
- , describe
- , it
- , shouldReturn
- )
-import Test.Hspec.Golden
- ( Golden (..)
- )
-
-import qualified Data.ByteString.Lazy.Char8 as BL
-
-spec :: Spec
-spec = do
- describe "data dir" $ do
- it "should exist" $ do
- f <- getDataDir
- doesDirectoryExist f `shouldReturn` True
- describe "swagger.yaml" $ do
- it "should be generated" $ do
- f <- getDataFileName "data/swagger.json"
- doesFileExist f `shouldReturn` True
- it "contains the actual schema" $ do
- f <- getDataFileName "data/swagger.json"
- let output' = generateOpenapi3
- pure $ swaggerGolden f $ BL.unpack output'
-
-swaggerGolden :: FilePath -> String -> Golden String
-swaggerGolden goldenPath output_ =
- Golden
- { output = output_
- , encodePretty = show
- , writeToFile = writeFile
- , readFromFile = readFile
- , goldenFile = goldenPath
- , actualFile = Nothing
- , failFirstTime = False
- }
diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs
deleted file mode 100644
index dac6c96651c..00000000000
--- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Map/TimedSpec.hs
+++ /dev/null
@@ -1,429 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Cardano.Wallet.Deposit.Map.TimedSpec where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.Map.Timed
- ( Timed (..)
- , TimedSeq
- , dropAfter
- , dropBefore
- , fromList
- , maxKey
- , minKey
- , takeAfter
- , takeUpTo
- , toList
- )
-import Data.List
- ( sort
- , unfoldr
- )
-import Data.Monoid
- ( Last (..)
- , Sum (..)
- )
-import Data.Time
- ( UTCTime (..)
- , defaultTimeLocale
- , parseTimeOrError
- , pattern YearMonthDay
- )
-import Test.Hspec
- ( Spec
- , describe
- , it
- , shouldBe
- , shouldNotBe
- )
-
-type UTimed = Timed UTCTime (Sum Int)
-
-type UTimedSeq = TimedSeq UTCTime (Sum Int)
-
-t :: String -> UTCTime
-t =
- parseTimeOrError False defaultTimeLocale "%Y-%m-%d %H:%M:%S"
-
-mkTimed :: String -> Int -> UTimed
-mkTimed s i = Timed (Last $ Just $ t s) (Sum i)
-
-t0 :: UTimed
-t0 = mkTimed "2021-01-01 00:00:00" 1
-
-t1 :: UTimed
-t1 = mkTimed "2021-01-02 00:00:00" 2
-
-t2 :: UTimed
-t2 = mkTimed "2021-02-01 00:00:00" 3
-
-t3 :: UTimed
-t3 = mkTimed "2021-02-02 00:00:00" 4
-
-t4 :: UTimed
-t4 = mkTimed "2022-02-03 00:00:00" 5
-
-t5 :: UTimed
-t5 = mkTimed "2022-02-03 12:00:00" 6
-
-t6 :: UTimed
-t6 = mkTimed "2022-03-03 12:00:00" 7
-
-t7 :: UTimed
-t7 = mkTimed "2022-03-05 12:00:00" 8
-
-ts :: [UTimed]
-ts = sort [t0, t1, t2, t3, t4, t5, t6, t7]
-
-result
- :: [UTimed]
- -> Maybe UTimed
- -> (UTimedSeq, Maybe UTCTime)
-result included next = (fromList included, nextTime)
- where
- nextTime = do
- Timed x _ <- next
- getLast x
-
-results :: [[UTimed]] -> [UTimedSeq]
-results = fmap fromList
-
-byYear :: UTCTime -> Integer
-byYear (UTCTime (YearMonthDay y _ _) _) = y
-
-byMonth :: UTCTime -> (Integer, Int)
-byMonth (UTCTime (YearMonthDay y m _) _) = (y, m)
-
-byDay :: UTCTime -> (Integer, Int, Int)
-byDay (UTCTime (YearMonthDay y m d) _) = (y, m, d)
-
-scroll
- :: (TimedSeq t a -> Maybe t)
- -> ( (t -> q)
- -> Maybe t
- -> Maybe Int
- -> TimedSeq t a
- -> (TimedSeq t a, Maybe t)
- )
- -> (t -> q)
- -> Int
- -> TimedSeq t a
- -> [TimedSeq t a]
-scroll boot extract bucket count pager = unfoldr f $ boot pager
- where
- f Nothing = Nothing
- f (Just start) = case extract bucket (Just start) (Just count) pager of
- (m, Just next) -> Just (m, Just next)
- (m, Nothing) -> Just (m, Nothing)
-
-spec :: Spec
-spec = do
- describe "takeAfter" $ do
- it "can extract without start" $ do
- takeAfter
- byDay
- Nothing
- (Just 1)
- (fromList ts)
- `shouldBe` result [t0] (Just t1)
- it "can extract without count" $ do
- takeAfter
- byDay
- (Just $ t "2021-01-01 00:00:00")
- Nothing
- (fromList ts)
- `shouldBe` result [t0, t1, t2, t3, t4 <> t5, t6, t7] Nothing
- it "can extract 1 day" $ do
- takeAfter
- byDay
- (Just $ t "2021-01-01 00:00:00")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t0] (Just t1)
- it "can extract 2 days" $ do
- takeAfter
- byDay
- (Just $ t "2021-01-01 00:00:00")
- (Just 2)
- (fromList ts)
- `shouldBe` result [t0, t1] (Just t2)
- it "can extract 5 days" $ do
- takeAfter
- byDay
- (Just $ t "2021-01-01 00:00:00")
- (Just 5)
- (fromList ts)
- `shouldBe` result [t0, t1, t2, t3, t4 <> t5] (Just t6)
- it "can extract 1 month" $ do
- takeAfter
- byMonth
- (Just $ t "2021-01-01 00:00:00")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t0 <> t1] (Just t2)
-
- it "can extract 2 months" $ do
- takeAfter
- byMonth
- (Just $ t "2021-01-01 00:00:00")
- (Just 2)
- (fromList ts)
- `shouldBe` result [t0 <> t1, t2 <> t3] (Just t4)
-
- it "can extract 3 months" $ do
- takeAfter
- byMonth
- (Just $ t "2021-01-01 00:00:00")
- (Just 3)
- (fromList ts)
- `shouldBe` result [t0 <> t1, t2 <> t3, t4 <> t5] (Just t6)
-
- it "can extract 1 year" $ do
- takeAfter
- byYear
- (Just $ t "2021-01-01 00:00:00")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t0 <> t1 <> t2 <> t3] (Just t4)
-
- it "can extract 2 years" $ do
- takeAfter
- byYear
- (Just $ t "2021-01-01 00:00:00")
- (Just 2)
- (fromList ts)
- `shouldBe` result [t0 <> t1 <> t2 <> t3, t4 <> t5 <> t6 <> t7] Nothing
-
- it "can extract 3 years" $ do
- takeAfter
- byYear
- (Just $ t "2021-01-01 00:00:00")
- (Just 3)
- (fromList ts)
- `shouldBe` result [t0 <> t1 <> t2 <> t3, t4 <> t5 <> t6 <> t7] Nothing
-
- it "can extract 1 day after t0" $ do
- takeAfter
- byDay
- (Just $ t "2021-01-01 00:00:01")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t1] (Just t2)
-
- it "can extract 1 month after t0" $ do
- takeAfter
- byMonth
- (Just $ t "2021-01-01 00:00:01")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t1] (Just t2)
-
- it "can extract 1 year after t0" $ do
- takeAfter
- byYear
- (Just $ t "2021-01-01 00:00:01")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t1 <> t2 <> t3] (Just t4)
- describe "takeBefore" $ do
- it "can extract without start" $ do
- takeUpTo
- byDay
- Nothing
- (Just 1)
- (fromList ts)
- `shouldBe` result [t7] (Just t6)
- it "can extract without count" $ do
- takeUpTo
- byDay
- (Just $ t "2022-03-05 12:00:00")
- Nothing
- (fromList ts)
- `shouldBe` result [t7, t6, t4 <> t5, t3, t2, t1, t0] Nothing
- it "can extract 1 day" $ do
- takeUpTo
- byDay
- (Just $ t "2022-03-05 12:00:00")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t7] (Just t6)
- it "can extract 2 days" $ do
- takeUpTo
- byDay
- (Just $ t "2022-03-05 12:00:00")
- (Just 2)
- (fromList ts)
- `shouldBe` result [t7, t6] (Just t5)
- it "can extract 3 days" $ do
- takeUpTo
- byDay
- (Just $ t "2022-03-05 12:00:00")
- (Just 3)
- (fromList ts)
- `shouldBe` result [t7, t6, t4 <> t5] (Just t3)
- it "can extract 1 month" $ do
- takeUpTo
- byMonth
- (Just $ t "2022-03-05 12:00:00")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t6 <> t7] (Just t5)
- it "can extract 2 months" $ do
- takeUpTo
- byMonth
- (Just $ t "2022-03-05 12:00:00")
- (Just 2)
- (fromList ts)
- `shouldBe` result [t6 <> t7, t4 <> t5] (Just t3)
- it "can extract 2 years" $ do
- takeUpTo
- byYear
- (Just $ t "2022-03-05 12:00:00")
- (Just 2)
- (fromList ts)
- `shouldBe` result
- [t4 <> t5 <> t6 <> t7, t0 <> t1 <> t2 <> t3]
- Nothing
- it "can extract 1 day before t7" $ do
- takeUpTo
- byDay
- (Just $ t "2022-03-05 11:59:59")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t6] (Just t5)
- it "can extract 1 month before t6" $ do
- takeUpTo
- byMonth
- (Just $ t "2022-03-03 11:59:59")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t4 <> t5] (Just t3)
- it "can extract 1 year before t4" $ do
- takeUpTo
- byYear
- (Just $ t "2022-01-02 23:59:59")
- (Just 1)
- (fromList ts)
- `shouldBe` result [t0 <> t1 <> t2 <> t3] Nothing
-
- describe "TimedSeq scroll" $ do
- it "can consume scrolling forward by 1 day" $ do
- scroll minKey takeAfter byDay 1 (fromList ts)
- `shouldBe` results
- [ [t0]
- , [t1]
- , [t2]
- , [t3]
- , [t4 <> t5]
- , [t6]
- , [t7]
- ]
- it "can consume scrolling backward by 1 day" $ do
- scroll maxKey takeUpTo byDay 1 (fromList ts)
- `shouldBe` results
- [ [t7]
- , [t6]
- , [t4 <> t5]
- , [t3]
- , [t2]
- , [t1]
- , [t0]
- ]
- it "can consume scrolling forward by 1 month" $ do
- scroll minKey takeAfter byMonth 1 (fromList ts)
- `shouldBe` results
- [ [t0 <> t1]
- , [t2 <> t3]
- , [t4 <> t5]
- , [t6 <> t7]
- ]
- it "can consume scrolling backward by 1 month" $ do
- scroll maxKey takeUpTo byMonth 1 (fromList ts)
- `shouldBe` results
- [ [t6 <> t7]
- , [t4 <> t5]
- , [t2 <> t3]
- , [t0 <> t1]
- ]
- it "can consume scrolling forward by 1 year" $ do
- scroll minKey takeAfter byYear 1 (fromList ts)
- `shouldBe` results
- [ [t0 <> t1 <> t2 <> t3]
- , [t4 <> t5 <> t6 <> t7]
- ]
- it "can consume scrolling backward by 1 year" $ do
- scroll maxKey takeUpTo byYear 1 (fromList ts)
- `shouldBe` results
- [ [t4 <> t5 <> t6 <> t7]
- , [t0 <> t1 <> t2 <> t3]
- ]
-
- describe "dropAfter function" $ do
- it "works on empty" $ do
- dropAfter @UTCTime @() (t "2021-01-01 00:00:00") (fromList [])
- `shouldBe` fromList []
- it "drop a single" $ do
- dropAfter (t "2021-01-01 00:00:00") (fromList [t0])
- `shouldBe` fromList [t0]
- it "take one and drop the second, early cut" $ do
- dropAfter (t "2021-01-01 00:00:00") (fromList [t0, t1])
- `shouldBe` fromList [t0]
- it "take one and drop the second, late cut" $ do
- dropAfter (t "2021-01-01 23:59:59") (fromList [t0, t1])
- `shouldBe` fromList [t0]
- it "can take all" $ do
- dropAfter (t "2021-01-02 00:00:00") (fromList [t0, t1])
- `shouldBe` fromList [t0, t1]
-
- describe "dropBefore function" $ do
- it "works on empty" $ do
- dropBefore @UTCTime @() (t "2021-01-01 00:00:00") (fromList [])
- `shouldBe` fromList []
- it "drop a single" $ do
- dropBefore (t "2021-01-01 00:00:01") (fromList [t0])
- `shouldBe` fromList []
- it "take second and drop the first, early cut" $ do
- dropBefore (t "2021-01-01 00:00:01") (fromList [t0, t1])
- `shouldBe` fromList [t1]
- it "take the second and drop the first, late cut" $ do
- dropBefore (t "2021-01-02 00:00:00") (fromList [t0, t1])
- `shouldBe` fromList [t1]
- it "can take all" $ do
- dropBefore (t "2021-01-01 00:00:00") (fromList [t0, t1])
- `shouldBe` fromList [t0, t1]
-
- describe "TimedSeq semigroup" $ do
- it "can append two sequences of distinct times" $ do
- fromList [t0, t1] <> fromList [t2, t3]
- `shouldBe` fromList [t0, t1, t2, t3]
- it "can append two sequences of overlapping edges in time" $ do
- fromList [t0, t1] <> fromList [t1, t2]
- `shouldBe` fromList
- [ t0
- , Timed (time t1) (monoid t1 <> monoid t1)
- , t2
- ]
- it "is used in fromList" $ do
- fromList [t0, t1, t1, t2]
- `shouldBe` fromList
- [ t0
- , Timed (time t1) (monoid t1 <> monoid t1)
- , t2
- ]
- describe "fromList" $ do
- it "is the inverse of toList for different ts" $ do
- fromList (toList (fromList ts)) `shouldBe` fromList ts
- it "is the inverse of toList for overlapping ts" $ do
- let ts' = [t0, t1, t1, t2]
- fromList (toList (fromList ts'))
- `shouldBe` fromList ts'
-
- describe "toList" $ do
- it "is not the inverse of fromList for overlapping ts" $ do
- let ts' = [t0, t1, t1, t2]
- toList (fromList ts') `shouldNotBe` ts'
diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs
deleted file mode 100644
index e4e57fee8b4..00000000000
--- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/AddressSpec.hs
+++ /dev/null
@@ -1,143 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-module Cardano.Wallet.Deposit.Pure.API.AddressSpec
- ( spec
- )
-where
-
-import Prelude
-
-import Cardano.Wallet.Deposit.Pure.API.Address
- ( DecodingError (..)
- , decodeAddress
- , encodeAddress
- )
-import Cardano.Wallet.Read.Address
- ( isBootstrapCompactAddr
- , toShortByteString
- )
-import Control.Monad
- ( forM_
- )
-import Data.ByteString.Base58
- ( bitcoinAlphabet
- , decodeBase58
- , encodeBase58
- )
-import Data.Either
- ( isLeft
- , isRight
- )
-import Data.Function
- ( (&)
- )
-import Data.Maybe
- ( isJust
- )
-import Data.Text
- ( Text
- )
-import Test.Cardano.Ledger.Core.Arbitrary
- ()
-import Test.Hspec
- ( Spec
- , describe
- , it
- , shouldBe
- )
-import Test.QuickCheck
- ( Arbitrary (..)
- , Gen
- , checkCoverage
- , counterexample
- , cover
- , elements
- , forAll
- , label
- , oneof
- , property
- , (===)
- )
-
-import qualified Codec.Binary.Bech32 as Bech32
-import qualified Codec.Binary.Bech32.TH as Bech32
-import qualified Data.ByteString.Short as SBS
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-
-spec :: Spec
-spec = do
- describe "address codec" $ do
- it "rountrips correctly on random addresses" $ forAll arbitrary $ \x ->
- decodeAddress (encodeAddress x)
- === Right x
-
- it "decodeAddress text = Right addr ==> encodeAddress addr == text"
- $ checkCoverage $ forAll genArbitrarilyEncodedAddress $ \text -> do
- let getErrorLabel e = case e of
- InvalidBech32Encoding _e -> "invalid bech32 encoding"
- InvalidBase58Encoding -> "invalid base58 encoding"
- InvalidHumanReadablePart _hrp -> "invalid hrp"
- InvalidDataPart _ -> "invalid data part"
- AddressFlavorMismatch -> "flavor mismatch"
- AddressDecodingError _ -> "decoding error"
- AddressNetworkMismatch -> "network mismatch"
-
- let res = decodeAddress text
- case res of
- Right addr -> label "success" $ encodeAddress addr === text
- Left e -> label (getErrorLabel e) $ property True
- & cover 0.2 (isLeft res) "failure"
- & cover 0.2 (isRight res) "success"
-
- it "isBootstrapAddr decides whether bech32 or base58 encoding is used"
- $ forAll arbitrary $ \addr ->
- let
- isBase58 = isJust . decodeBase58 bitcoinAlphabet . T.encodeUtf8
- isBech32 = isRight . Bech32.decodeLenient
-
- encodedAddr = encodeAddress addr
- in
- if isBootstrapCompactAddr addr
- then property $ isBase58 encodedAddr
- else property $ isBech32 encodedAddr
- & counterexample (T.unpack encodedAddr)
-
- it "roundtrips correctly on some addresses from online examples"
- $ do
- let testCases =
- [ "addr1z92l7rnra7sxjn5qv5fzc4fwsrrm29mgkleqj9a0y46j5lyjz4gwd3njhyqwntdkcm8rrgapudajydteywgtuvl6etjs9nqzg5"
- , "addr_test1wppg9l6relcpls4u667twqyggkrpfrs5cdge9hhl9cv2upchtch0h"
- , "37btjrVyb4KDXBNC4haBVPCrro8AQPHwvCMp3RFhhSVWwfFmZ6wwzSK6JK1hY6wHNmtrpTf1kdbva8TCneM2YsiXT7mrzT21EacHnPpz5YyUdj64na"
- ]
- forM_ testCases $ \addr ->
- encodeAddress <$> decodeAddress addr
- `shouldBe` Right addr
-
- it "fails to decode addresses where the network tag doesn't match the bech32 hrp" $ do
- let secretlyMainnetAddr = "addr_test1z92l7rnra7sxjn5qv5fzc4fwsrrm29mgkleqj9a0y46j5lyjz4gwd3njhyqwntdkcm8rrgapudajydteywgtuvl6etjshn59kk"
- decodeAddress secretlyMainnetAddr
- `shouldBe` Left AddressNetworkMismatch
-
--- | Generate 'Text' heavily biased towards values of incorrectly encoded
--- addresses
-genArbitrarilyEncodedAddress :: Gen Text
-genArbitrarilyEncodedAddress = oneof
- [ encodeAddrBech32 <$> genAddrHrp <*> arbitrary
- , encodeAddrBase58 <$> arbitrary
- ]
- where
- encodeAddrBech32 hrp addr = Bech32.encodeLenient hrp dataPart
- where
- bytes = SBS.fromShort $ toShortByteString addr
- dataPart = Bech32.dataPartFromBytes bytes
-
- genAddrHrp = elements
- [ [Bech32.humanReadablePart|addr|]
- , [Bech32.humanReadablePart|addr_test|]
- , [Bech32.humanReadablePart|notaddr|]
- ]
-
- encodeAddrBase58 = T.decodeUtf8
- . encodeBase58 bitcoinAlphabet
- . SBS.fromShort
- . toShortByteString
diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/TransactionSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/TransactionSpec.hs
deleted file mode 100644
index 66a08b50583..00000000000
--- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/TransactionSpec.hs
+++ /dev/null
@@ -1,239 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module Cardano.Wallet.Deposit.Pure.API.TransactionSpec
- ( spec
- )
-where
-
-import Prelude
-
-import Cardano.Ledger.Api
- ( ppMaxTxSizeL
- , ppMaxValSizeL
- )
-import Cardano.Ledger.BaseTypes
- ( EpochSize (..)
- )
-import qualified Cardano.Ledger.BaseTypes as Ledger
-import qualified Cardano.Ledger.Core as Ledger
-import qualified Cardano.Ledger.Shelley.API.Mempool as Ledger
-import qualified Cardano.Ledger.Shelley.LedgerState as Ledger
-import qualified Cardano.Ledger.Shelley.Rules as Ledger
-import qualified Cardano.Slotting.EpochInfo as Slotting
-import Cardano.Slotting.Time
- ( SlotLength
- , SystemStart (..)
- , mkSlotLength
- )
-import qualified Cardano.Wallet.Deposit.Pure.Address as Address
-import Cardano.Wallet.Deposit.Pure.API.Address
- ( encodeAddress
- )
-import Cardano.Wallet.Deposit.Pure.State.Creation
- ( accountXPubFromCredentials
- , createMnemonicFromWords
- , credentialsFromMnemonics
- )
-import Cardano.Wallet.Deposit.PureSpec
- ( testOnWallet
- )
-import Cardano.Wallet.Deposit.Read
- ( Address
- , Conway
- , NetworkTag (..)
- , UTxO
- , mkEnterpriseAddress
- )
-import Cardano.Wallet.Deposit.Testing.DSL
- ( assert
- , balance
- , block
- , deposit
- , existsTx
- , rollForward
- , sign
- , spend
- , utxo
- , wallet
- )
-import Cardano.Wallet.Deposit.Write
- ( Tx
- )
-import qualified Cardano.Wallet.Deposit.Write as Write
-import Cardano.Wallet.Read
- ( NetworkId (..)
- )
-import qualified Cardano.Wallet.Read as Read
-import Control.Lens
- ( (&)
- , (.~)
- )
-import qualified Data.ByteString.Short as SBS
-import Data.Default
- ( Default (..)
- )
-import Data.Maybe
- ( fromMaybe
- )
-import Data.Text
- ( Text
- )
-import qualified Data.Text.Lazy as TL
-import Data.Time.Clock.POSIX
- ( posixSecondsToUTCTime
- )
-import Test.Cardano.Ledger.Core.Arbitrary
- ()
-import Test.Hspec
- ( Spec
- , describe
- , it
- , shouldBe
- )
-import Text.Pretty.Simple
- ( pShow
- )
-
-address :: Address
-address = mockAddress
-
-mockAddress :: Address
-mockAddress =
- mkEnterpriseAddress
- MainnetTag
- (SBS.toShort "12345678901234567890123456789012")
-
-defaultPParams :: Ledger.PParams Conway
-defaultPParams =
- def
- & ppMaxTxSizeL .~ 16_384
- & ppMaxValSizeL .~ 1_000_000_000
-
--- | Create a new ledger env from given protocol parameters.
-newLedgerEnv :: Ledger.PParams Conway -> Ledger.LedgerEnv Conway
-newLedgerEnv protocolParams =
- Ledger.LedgerEnv
- { Ledger.ledgerSlotNo = 0
- , -- NOTE: This can probably stay at 0 forever. This is used internally by the
- -- node's mempool to keep track of transaction seen from peers. Transactions
- -- in Hydra do not go through the node's mempool and follow a different
- -- consensus path so this will remain unused.
- Ledger.ledgerIx = minBound
- , -- NOTE: This keeps track of the ledger's treasury and reserve which are
- -- both unused in Hydra. There might be room for interesting features in the
- -- future with these two but for now, we'll consider them empty.
- Ledger.ledgerAccount = Ledger.AccountState mempty mempty
- , Ledger.ledgerPp = protocolParams
- , Ledger.ledgerMempool = False
- }
-
-defaultLedgerEnv :: Ledger.LedgerEnv Conway
-defaultLedgerEnv = newLedgerEnv defaultPParams
-
-defaultGlobals :: Ledger.Globals
-defaultGlobals =
- Ledger.Globals
- { Ledger.epochInfo = Slotting.fixedEpochInfo epochSize slotLength
- , Ledger.slotsPerKESPeriod = 20
- , Ledger.stabilityWindow = 33
- , Ledger.randomnessStabilisationWindow = 33
- , Ledger.securityParameter = 10
- , Ledger.maxKESEvo = 10
- , Ledger.quorum = 5
- , Ledger.maxLovelaceSupply = 45 * 1000 * 1000 * 1000 * 1000 * 1000
- , Ledger.activeSlotCoeff =
- Ledger.mkActiveSlotCoeff . unsafeBoundRational $ 0.9
- , Ledger.networkId = Ledger.Mainnet
- , Ledger.systemStart = SystemStart $ posixSecondsToUTCTime 0
- }
- where
- unsafeBoundRational r =
- fromMaybe (error $ "Could not convert from Rational: " <> show r)
- $ Ledger.boundRational r
-
-epochSize :: EpochSize
-epochSize = EpochSize 100
-
-slotLength :: SlotLength
-slotLength = mkSlotLength 1
-
-applyTx
- :: UTxO
- -> Write.Tx
- -> Either
- (Ledger.ApplyTxError Conway)
- ()
-applyTx utxos (Read.Tx tx) =
- case Ledger.applyTx defaultGlobals defaultLedgerEnv memPoolState tx of
- Left err -> Left err
- Right _ -> Right ()
- where
- memPoolState =
- Ledger.LedgerState
- { Ledger.lsUTxOState =
- def{Ledger.utxosUtxo = Write.toConwayUTxO utxos}
- , Ledger.lsCertState = def
- }
-newtype Ledger = Ledger
- { validate :: Tx -> Either (Ledger.ApplyTxError Conway) ()
- }
-
-ledgerFrom :: UTxO -> Ledger
-ledgerFrom = Ledger . applyTx
-
-accepts :: Ledger -> Tx -> IO ()
-accepts l t = case validate l t of
- Left err ->
- error
- $ TL.unpack
- $ "Transaction was not accepted by the ledger: \n"
- <> pShow defaultPParams
- <> "\n"
- <> pShow t
- <> "\n"
- <> pShow err
- Right _ -> pure ()
-
-mnemonics :: Text
-mnemonics = "vital minimum victory start lunch find city peanut shiver soft hedgehog artwork mushroom loud found"
-
-spec :: Spec
-spec = do
- describe "balanced transaction" $ do
- it "has correct witness for one tx-in"
- $ testOnWallet
- $ do
- wallet 17 mnemonics "passphrase"
- tx1 <- existsTx
- u1 <- deposit tx1 1 100
- b1 <- block [tx1]
- rollForward [b1]
- spending <- existsTx
- spend spending address 10
- balanced <- balance spending
- utxos <- utxo u1
- signedTx <- sign balanced "passphrase"
- assert $ ledgerFrom utxos `accepts` signedTx
-
- -- cat root1.prv
- -- | cardano-address key child 1857H/1815H/0H/0/0 \
- -- | cardano-address key public --with-chain-code \
- -- | cardano-address address payment --network-tag mainnet
- describe "generated address match golden cases" $ do
- it "with empty passphrase in mainnet" $ do
- let
- Right seed = createMnemonicFromWords mnemonics
- address0 = "addr1v8th5554xvd2us9hwh72p3yt9rg7uw9v7tk49t3yw3wrcgc3drxft"
- creds = credentialsFromMnemonics seed mempty
- xpub = accountXPubFromCredentials creds
- addr =
- encodeAddress
- $ snd
- $ head
- $ Address.listCustomers
- $ Address.fromXPubAndCount Mainnet xpub 1
-
- addr `shouldBe` address0
diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs
deleted file mode 100644
index efb3844c038..00000000000
--- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs
+++ /dev/null
@@ -1,346 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Property tests for the deposit wallet.
-module Cardano.Wallet.Deposit.PureSpec
- ( spec
- , testOnWallet
- ) where
-
-import Prelude
-
-import Cardano.Mnemonic
- ( SomeMnemonic
- )
-import Cardano.Wallet.Deposit.Pure
- ( Credentials
- )
-import Cardano.Wallet.Deposit.Pure.API.TxHistory
- ( LookupTimeFromSlot
- )
-import Cardano.Wallet.Deposit.Pure.State.Creation
- ( createMnemonicFromWords
- , credentialsFromMnemonics
- )
-import Cardano.Wallet.Deposit.Testing.DSL
- ( InterpreterState (..)
- , ScenarioP
- , assert
- , availableBalance
- , block
- , deposit
- , deposit_
- , existsTx
- , historyByCustomer
- , historyByTime
- , interpret
- , newHistoryByTime
- , rollBackward
- , rollForward
- , withdrawal
- )
-import Cardano.Wallet.Deposit.Testing.DSL.ByTime
- ( atBlock
- , byCustomerFromByTime
- , deposited
- , forCustomer
- , inTx
- , newByTime
- , withdrawn
- )
-import Cardano.Wallet.Deposit.Time
- ( unsafeUTCTimeOfSlot
- )
-import Control.Monad.Trans.State
- ( StateT
- )
-import Data.Maybe
- ( fromJust
- )
-import Data.Time
- ( UTCTime
- )
-import Test.Hspec
- ( Spec
- , describe
- , it
- , shouldBe
- )
-import Test.QuickCheck
- ( Property
- , (.&&.)
- , (=/=)
- , (===)
- )
-
-import qualified Cardano.Wallet.Deposit.Pure as Wallet
-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.Map.Strict as Map
-import qualified Data.Set as Set
-
-timeFromSlot :: LookupTimeFromSlot
-timeFromSlot = unsafeUTCTimeOfSlot
-
-unsafeTimeForSlot :: Read.Slot -> Read.WithOrigin UTCTime
-unsafeTimeForSlot = fromJust . timeFromSlot
-
-testOnWallet
- :: ScenarioP
- (IO ())
- (StateT (Wallet.WalletState, InterpreterState) IO)
- ()
- -> IO ()
-testOnWallet =
- interpret
- emptyWalletWith17Addresses
- id
- unsafeTimeForSlot
-
-spec :: Spec
-spec = do
- describe "UTxO availableBalance" $ do
- it
- "rollForward twice"
- prop_availableBalance_rollForward_twice
- it
- "rollBackward . rollForward"
- prop_availableBalance_rollForward_rollBackward
- describe "history by time" $ do
- it "is empty after initialization"
- $ testOnWallet
- $ do
- ht0 <- historyByTime
- assert $ ht0 `shouldBe` mempty
- hc0 <- historyByCustomer
- assert $ hc0 `shouldBe` mempty
- it "reports a tx after a rollforward"
- $ testOnWallet
- $ do
- tx1 <- existsTx
- deposit_ tx1 1 100
- b1 <- block [tx1]
- rollForward [b1]
- h1 <- historyByTime
- h1' <- newHistoryByTime $ newByTime $ do
- atBlock b1 $ do
- forCustomer 1 $ do
- inTx tx1 $ deposited 100
- assert $ h1 `shouldBe` h1'
- hc1 <- historyByCustomer
- assert $ hc1 `shouldBe` byCustomerFromByTime h1'
- balance <- availableBalance
- assert $ balance `shouldBe` 100_000_000
- it "reports multiple blocks after a rollforward"
- $ testOnWallet
- $ do
- tx1 <- existsTx
- deposit_ tx1 1 100
- b1 <- block [tx1]
- tx2 <- existsTx
- deposit_ tx2 1 200
- b2 <- block [tx2]
- rollForward [b1, b2]
- h1 <- historyByTime
- h1' <- newHistoryByTime $ newByTime $ do
- atBlock b1 $ do
- forCustomer 1 $ do
- inTx tx1 $ deposited 100
- atBlock b2 $ do
- forCustomer 1 $ do
- inTx tx2 $ deposited 200
- assert $ h1 `shouldBe` h1'
- hc1 <- historyByCustomer
- assert $ hc1 `shouldBe` byCustomerFromByTime h1'
- balance <- availableBalance
- assert $ balance `shouldBe` 300_000_000
- it "reports withdrawals in separate blocks from deposits"
- $ testOnWallet
- $ do
- tx1 <- existsTx
- w1 <- deposit tx1 1 100
- b1 <- block [tx1]
- tx2 <- existsTx
- withdrawal tx2 w1
- b2 <- block [tx2]
- rollForward [b1, b2]
- h1 <- historyByTime
- h1' <- newHistoryByTime $ newByTime $ do
- atBlock b1 $ do
- forCustomer 1 $ do
- inTx tx1 $ deposited 100
- atBlock b2 $ do
- forCustomer 1 $ do
- inTx tx2 $ withdrawn 100
- assert $ h1 `shouldBe` h1'
- hc1 <- historyByCustomer
- assert $ hc1 `shouldBe` byCustomerFromByTime h1'
- balance <- availableBalance
- assert $ balance `shouldBe` 0
- it "reports withdrawals in the same block as deposits"
- $ testOnWallet
- $ do
- tx1 <- existsTx
- w1 <- deposit tx1 1 100
- tx2 <- existsTx
- withdrawal tx2 w1
- b1 <- block [tx1, tx2]
- rollForward [b1]
- h1 <- historyByTime
- h1' <- newHistoryByTime $ newByTime $ do
- atBlock b1 $ do
- forCustomer 1 $ do
- inTx tx1 $ deposited 100
- inTx tx2 $ withdrawn 100
- assert $ h1 `shouldBe` h1'
- hc1 <- historyByCustomer
- assert $ hc1 `shouldBe` byCustomerFromByTime h1'
- balance <- availableBalance
- assert $ balance `shouldBe` 0
-
- it "is empty after a full rollback"
- $ testOnWallet
- $ do
- tx1 <- existsTx
- deposit_ tx1 1 100
- b1 <- block [tx1]
- rollForward [b1]
- rollBackward Nothing
- h1 <- historyByTime
- assert $ h1 `shouldBe` mempty
- hc1 <- historyByCustomer
- assert $ hc1 `shouldBe` mempty
- balance <- availableBalance
- assert $ balance `shouldBe` 0
- it "contains the blocks not rolled back after a partial rollback"
- $ testOnWallet
- $ do
- tx1 <- existsTx
- deposit_ tx1 1 100
- b1 <- block [tx1]
- tx2 <- existsTx
- deposit_ tx2 1 200
- b2 <- block [tx2]
- rollForward [b1, b2]
- rollBackward $ Just b1
- h1 <- historyByTime
- h1' <- newHistoryByTime $ newByTime $ do
- atBlock b1 $ do
- forCustomer 1 $ do
- inTx tx1 $ deposited 100
- assert $ h1 `shouldBe` h1'
- hc1 <- historyByCustomer
- assert $ hc1 `shouldBe` byCustomerFromByTime h1'
- balance <- availableBalance
- assert $ balance `shouldBe` 100_000_000
-
-{-----------------------------------------------------------------------------
- Properties
-------------------------------------------------------------------------------}
-prop_availableBalance_rollForward_twice :: Property
-prop_availableBalance_rollForward_twice =
- Wallet.availableBalance w2 === Write.mkAda 3
- where
- w0 = emptyWalletWith17Addresses
- Just addr1 = Wallet.customerAddress 1 w0
- Just addr2 = Wallet.customerAddress 2 w0
-
- tx1 = payFromFaucet [(addr1, Write.mkAda 1)]
- block1 = Read.mockNextBlock Read.GenesisPoint [tx1]
- chainPoint1 = Read.getChainPoint block1
- w1 = Wallet.rollForwardOne timeFromSlot (Read.EraValue block1) w0
-
- tx2 = payFromFaucet [(addr2, Write.mkAda 2)]
- block2 = Read.mockNextBlock chainPoint1 [tx2]
- w2 = Wallet.rollForwardOne timeFromSlot (Read.EraValue block2) w1
-
-prop_availableBalance_rollForward_rollBackward :: Property
-prop_availableBalance_rollForward_rollBackward =
- Wallet.availableBalance
- (fst $ Wallet.rollBackward timeFromSlot chainPoint0 w3)
- === Wallet.availableBalance w0
- .&&. Wallet.availableBalance
- (fst $ Wallet.rollBackward timeFromSlot chainPoint1 w3)
- === Wallet.availableBalance w1
- .&&. Wallet.availableBalance
- (fst $ Wallet.rollBackward timeFromSlot chainPoint2 w3)
- === Wallet.availableBalance w2
- .&&. Wallet.availableBalance w3
- =/= Wallet.availableBalance w2
- .&&. Wallet.availableBalance w3
- `Read.lessOrEqual` Wallet.availableBalance w2
- where
- w0 = emptyWalletWith17Addresses
- Just addr1 = Wallet.customerAddress 1 w0
- Just addr2 = Wallet.customerAddress 2 w0
- chainPoint0 = Read.GenesisPoint
-
- tx1 = payFromFaucet [(addr1, Write.mkAda 1)]
- block1 = Read.mockNextBlock chainPoint0 [tx1]
- w1 = Wallet.rollForwardOne timeFromSlot (Read.EraValue block1) w0
- chainPoint1 = Read.getChainPoint block1
-
- tx2 = payFromFaucet [(addr2, Write.mkAda 2)]
- block2 = Read.mockNextBlock chainPoint1 [tx2]
- chainPoint2 = Read.getChainPoint block2
- w2 = Wallet.rollForwardOne timeFromSlot (Read.EraValue block2) w1
-
- tx3 = spendOneTxOut (Wallet.availableUTxO w2)
- block3 = Read.mockNextBlock chainPoint2 [tx3]
- w3 = Wallet.rollForwardOne timeFromSlot (Read.EraValue block3) w2
-
-emptyWalletWith17Addresses :: Wallet.WalletState
-emptyWalletWith17Addresses =
- Wallet.fromCredentialsAndGenesis testCredentials 17 testGenesis
-
-seed :: SomeMnemonic
-seed = case createMnemonicFromWords
- "vital minimum victory start lunch find city peanut shiver soft hedgehog artwork mushroom loud found"
- of
- Right seed' -> seed'
- Left e -> error $ show e
-
-testCredentials :: Credentials
-testCredentials =
- credentialsFromMnemonics seed mempty
-
-{-----------------------------------------------------------------------------
- Test blockchain
-------------------------------------------------------------------------------}
-
-testGenesis :: Read.GenesisData
-testGenesis = Read.mockGenesisDataMainnet
-
-spendOneTxOut :: UTxO.UTxO -> Write.Tx
-spendOneTxOut utxo =
- Write.mkTx txBody
- where
- txBody =
- Write.TxBody
- { Write.spendInputs = Set.singleton . fst . head $ Map.toList utxo
- , Write.collInputs = mempty
- , Write.txouts = Map.empty
- , Write.collRet = Nothing
- , Write.expirySlot = Nothing
- }
-
-payFromFaucet :: [(Write.Address, Write.Value)] -> Write.Tx
-payFromFaucet destinations =
- Write.mkTx txBody
- where
- toTxOut (addr, value) = Write.mkTxOut addr value
- txBody =
- Write.TxBody
- { Write.spendInputs = mempty
- , Write.collInputs = mempty
- , Write.txouts =
- Map.fromList $ zip [toEnum 0 ..] $ map toTxOut destinations
- , Write.collRet = Nothing
- , Write.expirySlot = Nothing
- }
diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs
deleted file mode 100644
index 76d394b15d3..00000000000
--- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs
+++ /dev/null
@@ -1,250 +0,0 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module Cardano.Wallet.Deposit.RESTSpec
- ( spec
- )
-where
-
-import Prelude
-
-import Cardano.Crypto.Wallet
- ( sign
- , verify
- , xPrvChangePass
- )
-import Cardano.Mnemonic
- ( SomeMnemonic
- )
-import Cardano.Wallet.Deposit.IO
- ( WalletBootEnv (WalletBootEnv)
- )
-import Cardano.Wallet.Deposit.IO.Resource
- ( ErrResourceMissing (..)
- , withResource
- )
-import Cardano.Wallet.Deposit.Pure.State.Creation
- ( Credentials
- , accountXPubFromCredentials
- , createMnemonicFromWords
- , credentialsFromMnemonics
- , deriveAccountXPrv
- , rootXPrvFromCredentials
- )
-import Cardano.Wallet.Deposit.REST
- ( ErrCreatingDatabase (..)
- , ErrDatabase (..)
- , ErrLoadingDatabase (..)
- , ErrWalletResource (..)
- , WalletResourceM
- , availableBalance
- , initWallet
- , loadWallet
- , runWalletResourceM
- , walletExists
- )
-import Codec.Serialise
- ( deserialise
- , serialise
- )
-import Control.Concurrent
- ( threadDelay
- )
-import Control.Monad.IO.Class
- ( MonadIO (..)
- )
-import Control.Monad.Trans.Cont
- ( cont
- , evalCont
- )
-import Control.Tracer
- ( nullTracer
- )
-import Data.ByteString
- ( ByteString
- )
-import Data.Maybe
- ( fromJust
- )
-import Data.Text
- ( Text
- )
-import System.IO.Temp
- ( withSystemTempDirectory
- )
-import Test.Hspec
- ( Spec
- , describe
- , it
- , shouldBe
- )
-import Test.QuickCheck
- ( Gen
- , arbitrary
- , elements
- , forAll
- , listOf
- , (===)
- )
-
-import qualified Cardano.Wallet.Deposit.Read as Read
-import qualified Data.ByteString.Char8 as B8
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-
-fakeBootEnv :: WalletBootEnv IO
-fakeBootEnv = WalletBootEnv nullTracer Read.mockGenesisDataMainnet undefined
-
-seed :: SomeMnemonic
-Right seed =
- createMnemonicFromWords
- "vital minimum victory start lunch find city peanut shiver soft hedgehog artwork mushroom loud found"
-
-credentials :: Credentials
-credentials = credentialsFromMnemonics seed mempty
-
-letItInitialize :: WalletResourceM ()
-letItInitialize = liftIO $ threadDelay 100000
-
-onSuccess :: (Show e, MonadFail m) => Either e a -> (a -> m b) -> m b
-onSuccess (Left e) _ = fail $ show e
-onSuccess (Right a) f = f a
-
-matchEmptyValue :: Show e => Either e Read.Value -> IO ()
-matchEmptyValue x = onSuccess x $ \v -> v `shouldBe` mempty
-
-withWallet :: WalletResourceM a -> IO (Either ErrWalletResource a)
-withWallet f = withResource $ runWalletResourceM f
-
-withInitializedWallet
- :: FilePath
- -> WalletResourceM a
- -> IO (Either ErrWalletResource a)
-withInitializedWallet dir f = withWallet $ do
- initWallet nullTracer nullTracer fakeBootEnv dir credentials 0
- letItInitialize
- f
-
-withLoadedWallet
- :: FilePath
- -> WalletResourceM a
- -> IO (Either ErrWalletResource a)
-withLoadedWallet dir f = withWallet $ do
- loadWallet nullTracer fakeBootEnv dir
- letItInitialize
- f
-
-doNothing :: WalletResourceM ()
-doNothing = pure ()
-
-inADirectory :: (FilePath -> IO a) -> IO a
-inADirectory = withSystemTempDirectory "deposit-rest"
-
-byteStringGen :: Gen ByteString
-byteStringGen = B8.pack <$> listOf arbitrary
-
-textGen :: Gen Text
-textGen = T.pack <$> listOf arbitrary
-
-words15 :: [Text]
-words15 =
- [ "soap retire song hat major steak stuff daughter half scorpion please brisk decade hill song"
- , "sure cannon broom caution artist legend boring reveal scene rubber weapon chest page clog fine"
- , "fruit garden saddle upper huge educate fabric ocean bamboo verb iron apple have deposit trap"
- ]
-
-credentialsGen :: Gen (Credentials, Text)
-credentialsGen = do
- mnemonics' <- elements words15
- case createMnemonicFromWords mnemonics' of
- Left e -> error $ "Invalid mnemonics: " <> show e
- Right seed' -> do
- passphrase' <- textGen
- pure (credentialsFromMnemonics seed' passphrase', passphrase')
-
-spec :: Spec
-spec = do
- describe "XPub" $ do
- it "can be serialised and deserialised" $ do
- forAll credentialsGen $ \(credentials', _) ->
- deserialise (serialise $ accountXPubFromCredentials credentials')
- === accountXPubFromCredentials credentials'
- describe "XPrv" $ do
- it "can be serialised and deserialised" $ do
- forAll credentialsGen $ \(credentials', _) ->
- deserialise (serialise $ rootXPrvFromCredentials credentials')
- === rootXPrvFromCredentials credentials'
- describe "Credentials" $ do
- it "can be serialised and deserialised" $ do
- forAll credentialsGen $ \(credentials', _) ->
- deserialise (serialise credentials') === credentials'
- describe "Credentials with mnemonics" $ do
- it "can sign and verify a message" $ evalCont $ do
- (credentials', passphrase') <- cont $ forAll credentialsGen
- message <- cont $ forAll byteStringGen
- let
- decryptXPrv =
- xPrvChangePass (T.encodeUtf8 passphrase') B8.empty
- xprv =
- deriveAccountXPrv
- $ decryptXPrv
- $ fromJust
- $ rootXPrvFromCredentials credentials'
- sig = sign B8.empty xprv message
- pure
- $ verify (accountXPubFromCredentials credentials') message sig
- === True
-
- describe "REST Deposit interface" $ do
- it "can initialize a wallet"
- $ inADirectory
- $ \dir -> do
- val <- withInitializedWallet dir availableBalance
- matchEmptyValue val
- it "can load an existing wallet"
- $ inADirectory
- $ \dir -> do
- val <- withInitializedWallet dir availableBalance
- onSuccess val $ \_ -> do
- val' <- withLoadedWallet dir availableBalance
- matchEmptyValue val'
- it "cannot re-initialize a wallet"
- $ inADirectory
- $ \dir -> do
- val <- withInitializedWallet dir doNothing
- onSuccess val $ \_ -> do
- val' <- withInitializedWallet dir availableBalance
- case val' of
- Left
- ( ErrNoWallet
- ( ErrFailedToInitialize
- ( ErrCreatingDatabase
- (ErrDatabaseAlreadyExists fp)
- )
- )
- )
- | dir == fp -> pure ()
- Left e -> fail $ show e
- Right _ -> fail "Should have failed the query on re-init"
- it "cannot load a non-existing wallet"
- $ inADirectory
- $ \dir -> do
- val <- withLoadedWallet dir availableBalance
- case val of
- Left
- ( ErrNoWallet
- ( ErrFailedToInitialize
- ( ErrLoadingDatabase
- (ErrDatabaseNotFound fp)
- )
- )
- )
- | dir == fp -> pure ()
- Left e -> fail $ show e
- Right _ -> fail "Should have failed the query on load"
- it "can check if a wallet is present on disk"
- $ inADirectory
- $ \dir -> do
- r <- withInitializedWallet dir doNothing
- onSuccess r $ \_ -> do
- presence <- walletExists dir
- presence `shouldBe` True
diff --git a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Write/KeysSpec.hs b/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Write/KeysSpec.hs
deleted file mode 100644
index 872cbe6c9ed..00000000000
--- a/lib/deposit-wallet/test/unit/Cardano/Wallet/Deposit/Write/KeysSpec.hs
+++ /dev/null
@@ -1,114 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
--- |
--- Copyright: © 2024 Cardano Foundation
--- License: Apache-2.0
---
--- Property tests for the deposit wallet.
-module Cardano.Wallet.Deposit.Write.KeysSpec
- ( spec
- ) where
-
-import Prelude
-
-import Cardano.Crypto.Wallet
- ( generate
- )
-import Cardano.Wallet.Address.BIP32_Ed25519
- ( XPrv
- , XPub
- , sign
- , toXPub
- )
-import "customer-deposit-wallet-pure" Cardano.Wallet.Address.Encoding
- ( EnterpriseAddr (..)
- , NetworkTag (..)
- , compactAddrFromEnterpriseAddr
- , credentialFromXPub
- )
-import Cardano.Wallet.Deposit.Write.Keys
- ( enterpriseAddressFromVKey
- , signedDSIGNfromXSignature
- , vkeyFromXPub
- )
-import Test.Hspec
- ( Spec
- , describe
- , it
- )
-import Test.QuickCheck
- ( Arbitrary (..)
- , Blind (..)
- , Property
- , elements
- , property
- , vectorOf
- , withMaxSuccess
- , (===)
- )
-
-import qualified Cardano.Crypto.Hash.Blake2b as Hash
-import qualified Cardano.Crypto.Hash.Class as Hash
-import qualified Cardano.Ledger.BaseTypes as L
-import qualified Cardano.Ledger.Hashes as L
-import qualified Cardano.Ledger.Keys as L
-import qualified Cardano.Wallet.Read as Read
-import qualified Data.ByteString as BS
-
-{-----------------------------------------------------------------------------
- Spec
-------------------------------------------------------------------------------}
-spec :: Spec
-spec = do
- describe "commutes with ledger" $ do
- it "address" $ lessCryptography $ property $
- \xpub networkTag ->
- let network = toLedgerNetwork networkTag
- in enterpriseAddressFromVKey network (vkeyFromXPub xpub)
- === enterpriseAddressFromXPub networkTag xpub
-
- it "verify" $ lessCryptography $ property $
- \(Blind xprv) hash ->
- let xpub = toXPub xprv
- xsig = sign xprv (Hash.hashToBytes hash)
- in
- True ===
- L.verifySignedDSIGN
- (vkeyFromXPub xpub)
- hash
- (signedDSIGNfromXSignature xsig)
-
-lessCryptography :: Property -> Property
-lessCryptography = withMaxSuccess 20
-
-{-----------------------------------------------------------------------------
- Helper functions
-------------------------------------------------------------------------------}
-enterpriseAddressFromXPub :: NetworkTag -> XPub -> Read.CompactAddr
-enterpriseAddressFromXPub networkTag =
- compactAddrFromEnterpriseAddr
- . EnterpriseAddrC networkTag
- . credentialFromXPub
-
-toLedgerNetwork :: NetworkTag -> L.Network
-toLedgerNetwork MainnetTag = L.Mainnet
-toLedgerNetwork TestnetTag = L.Testnet
-
-instance Arbitrary NetworkTag where
- arbitrary = elements [MainnetTag, TestnetTag]
-
-instance Arbitrary XPrv where
- arbitrary = generate . BS.pack <$> vectorOf 100 arbitrary <*> pure BS.empty
-
-instance Arbitrary XPub where
- arbitrary = toXPub <$> arbitrary
-
-instance Arbitrary (Hash.Hash Hash.Blake2b_256 L.EraIndependentTxBody) where
- arbitrary = do
- bytes <- BS.pack <$> vectorOf (32) arbitrary
- let Just hash = Hash.hashFromBytes bytes
- pure hash
diff --git a/lib/deposit-wallet/test/unit/Spec.hs b/lib/deposit-wallet/test/unit/Spec.hs
deleted file mode 100644
index 5416ef6a866..00000000000
--- a/lib/deposit-wallet/test/unit/Spec.hs
+++ /dev/null
@@ -1 +0,0 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
diff --git a/lib/deposit-wallet/test/unit/test-suite-unit.hs b/lib/deposit-wallet/test/unit/test-suite-unit.hs
deleted file mode 100644
index 66edcab2e95..00000000000
--- a/lib/deposit-wallet/test/unit/test-suite-unit.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module Main where
-
-import Prelude
-
-import Main.Utf8
- ( withUtf8
- )
-import Test.Hspec.Extra
- ( hspecMain
- )
-
-import qualified Spec
-
-main :: IO ()
-main = withUtf8 $ hspecMain Spec.spec
diff --git a/nix/project-package-list.nix b/nix/project-package-list.nix
index fd1ec47c8d5..ceff1329d92 100644
--- a/nix/project-package-list.nix
+++ b/nix/project-package-list.nix
@@ -1 +1 @@
-[ "address-derivation-discovery" "cardano-api-extra" "cardano-balance-tx" "cardano-coin-selection" "cardano-numeric" "cardano-wallet" "cardano-wallet-api" "cardano-wallet-application-extras" "cardano-wallet-benchmarks" "cardano-wallet-blackbox-benchmarks" "cardano-wallet-buildkite" "cardano-wallet-exe" "cardano-wallet-integration" "cardano-wallet-launcher" "cardano-wallet-network-layer" "cardano-wallet-primitive" "cardano-wallet-secrets" "cardano-wallet-test-utils" "cardano-wallet-ui" "cardano-wallet-unit" "crypto-primitives" "cardano-deposit-wallet" "delta-chain" "delta-store" "delta-table" "delta-types" "faucet" "iohk-monitoring-extra" "local-cluster" "std-gen-seed" "temporary-extra" "text-class" "wai-middleware-logging" ]
+[ "address-derivation-discovery" "cardano-api-extra" "cardano-balance-tx" "cardano-coin-selection" "cardano-numeric" "cardano-wallet" "cardano-wallet-api" "cardano-wallet-application-extras" "cardano-wallet-benchmarks" "cardano-wallet-blackbox-benchmarks" "cardano-wallet-buildkite" "cardano-wallet-exe" "cardano-wallet-integration" "cardano-wallet-launcher" "cardano-wallet-network-layer" "cardano-wallet-primitive" "cardano-wallet-secrets" "cardano-wallet-test-utils" "cardano-wallet-ui" "cardano-wallet-unit" "crypto-primitives" "delta-chain" "delta-store" "delta-table" "delta-types" "faucet" "iohk-monitoring-extra" "local-cluster" "std-gen-seed" "temporary-extra" "text-class" "wai-middleware-logging" ]