├── .gitignore ├── .vscode └── settings.json ├── LICENSE ├── README.md ├── algebra-core ├── CHANGELOG.md ├── algebra-core.cabal └── src │ └── Algebra │ └── Natural.hs ├── cabal.project ├── cardano-tx ├── CHANGELOG.md ├── cardano-tx.cabal └── src │ └── CardanoTx │ ├── Address.hs │ ├── Interop.hs │ ├── Models.hs │ ├── ToPlutus.hs │ ├── Types.hs │ └── Value.hs ├── datum-keeper-client ├── CHANGELOG.md ├── datum-keeper-client.cabal └── src │ └── DatumKeeper │ ├── Client.hs │ └── Config │ └── KeeperConfig.hs ├── default.nix ├── dex-core ├── CHANGELOG.md ├── dex-core.cabal ├── src │ └── ErgoDex │ │ ├── Amm │ │ ├── Constants.hs │ │ ├── Orders.hs │ │ ├── Pool.hs │ │ ├── PoolActions.hs │ │ └── PoolSetup.hs │ │ ├── Class.hs │ │ ├── ScriptsValidators.hs │ │ ├── State.hs │ │ ├── Types.hs │ │ └── Validators.hs └── test │ ├── Main.hs │ └── Spec │ └── Pool.hs ├── ergo-hs-common ├── CHANGELOG.md ├── ergo-hs-common.cabal └── src │ └── Common │ ├── Data │ └── List │ │ └── Combinators.hs │ └── Throw │ └── Combinators.hs ├── hie.yaml ├── ledger-sync ├── CHANGELOG.md ├── ledger-sync.cabal └── src │ ├── Cardano │ └── Network │ │ └── Protocol │ │ └── NodeToClient │ │ └── Trace.hs │ └── Spectrum │ ├── Config.hs │ ├── EventSource │ ├── Data │ │ ├── Tx.hs │ │ ├── TxContext.hs │ │ └── TxEvent.hs │ ├── Persistence │ │ ├── Config.hs │ │ ├── Data │ │ │ └── BlockLinks.hs │ │ └── LedgerHistory.hs │ ├── Stream.hs │ └── Types.hs │ ├── LedgerSync.hs │ ├── LedgerSync │ ├── Config.hs │ ├── Data │ │ ├── LedgerUpdate.hs │ │ └── MempoolUpdate.hs │ ├── Exception.hs │ └── Protocol │ │ ├── ChainSync.hs │ │ ├── Client.hs │ │ ├── Data │ │ ├── ChainSync.hs │ │ └── MempoolSync.hs │ │ └── MempoolSync.hs │ └── Topic.hs ├── network-api ├── CHANGELOG.md ├── network-api.cabal └── src │ └── NetworkAPI │ ├── Service.hs │ └── Types.hs ├── nix ├── default.nix ├── lib │ └── ci.nix ├── pkgs │ ├── default.nix │ └── haskell │ │ ├── default.nix │ │ └── haskell.nix ├── sources.json └── sources.nix ├── quickblue ├── CHANGELOG.md ├── quickblue.cabal └── src │ └── Explorer │ ├── Class.hs │ ├── Config.hs │ ├── Models.hs │ ├── Service.hs │ └── Types.hs ├── release.nix ├── shell.nix ├── spectrum-prelude ├── CHANGELOG.md ├── spectrum-prelude.cabal └── src │ └── Spectrum │ └── Prelude │ ├── Context.hs │ ├── Throw.hs │ └── UnliftIO.hs ├── spectrum ├── CHANGELOG.md ├── spectrum.cabal └── src │ └── Spectrum │ ├── Common │ └── Persistence │ │ ├── Exception.hs │ │ └── Serialization.hs │ └── Prelude │ └── HigherKind.hs ├── submit-api ├── CHANGELOG.md ├── src │ └── SubmitAPI │ │ ├── Config.hs │ │ ├── Internal │ │ ├── Balancing.hs │ │ └── Transaction.hs │ │ └── Service.hs ├── submit-api.cabal └── test │ ├── Gen │ └── CardanoTx.hs │ ├── Main.hs │ └── Spec │ ├── Network.hs │ └── Transaction.hs └── wallet-api ├── CHANGELOG.md ├── src └── WalletAPI │ ├── Internal │ ├── Crypto.hs │ └── Models.hs │ ├── TrustStore.hs │ ├── UtxoStore.hs │ ├── UtxoStoreConfig.hs │ ├── Utxos.hs │ └── Vault.hs └── wallet-api.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | result* 25 | .envrc 26 | .vim 27 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "nixEnvSelector.nixFile": "${workspaceRoot}/shell.nix" 3 | } -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Creative Commons Legal Code 2 | 3 | CC0 1.0 Universal 4 | 5 | CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE 6 | LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN 7 | ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS 8 | INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES 9 | REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS 10 | PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM 11 | THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED 12 | HEREUNDER. 13 | 14 | Statement of Purpose 15 | 16 | The laws of most jurisdictions throughout the world automatically confer 17 | exclusive Copyright and Related Rights (defined below) upon the creator 18 | and subsequent owner(s) (each and all, an "owner") of an original work of 19 | authorship and/or a database (each, a "Work"). 20 | 21 | Certain owners wish to permanently relinquish those rights to a Work for 22 | the purpose of contributing to a commons of creative, cultural and 23 | scientific works ("Commons") that the public can reliably and without fear 24 | of later claims of infringement build upon, modify, incorporate in other 25 | works, reuse and redistribute as freely as possible in any form whatsoever 26 | and for any purposes, including without limitation commercial purposes. 27 | These owners may contribute to the Commons to promote the ideal of a free 28 | culture and the further production of creative, cultural and scientific 29 | works, or to gain reputation or greater distribution for their Work in 30 | part through the use and efforts of others. 31 | 32 | For these and/or other purposes and motivations, and without any 33 | expectation of additional consideration or compensation, the person 34 | associating CC0 with a Work (the "Affirmer"), to the extent that he or she 35 | is an owner of Copyright and Related Rights in the Work, voluntarily 36 | elects to apply CC0 to the Work and publicly distribute the Work under its 37 | terms, with knowledge of his or her Copyright and Related Rights in the 38 | Work and the meaning and intended legal effect of CC0 on those rights. 39 | 40 | 1. Copyright and Related Rights. A Work made available under CC0 may be 41 | protected by copyright and related or neighboring rights ("Copyright and 42 | Related Rights"). Copyright and Related Rights include, but are not 43 | limited to, the following: 44 | 45 | i. the right to reproduce, adapt, distribute, perform, display, 46 | communicate, and translate a Work; 47 | ii. moral rights retained by the original author(s) and/or performer(s); 48 | iii. publicity and privacy rights pertaining to a person's image or 49 | likeness depicted in a Work; 50 | iv. rights protecting against unfair competition in regards to a Work, 51 | subject to the limitations in paragraph 4(a), below; 52 | v. rights protecting the extraction, dissemination, use and reuse of data 53 | in a Work; 54 | vi. database rights (such as those arising under Directive 96/9/EC of the 55 | European Parliament and of the Council of 11 March 1996 on the legal 56 | protection of databases, and under any national implementation 57 | thereof, including any amended or successor version of such 58 | directive); and 59 | vii. other similar, equivalent or corresponding rights throughout the 60 | world based on applicable law or treaty, and any national 61 | implementations thereof. 62 | 63 | 2. Waiver. To the greatest extent permitted by, but not in contravention 64 | of, applicable law, Affirmer hereby overtly, fully, permanently, 65 | irrevocably and unconditionally waives, abandons, and surrenders all of 66 | Affirmer's Copyright and Related Rights and associated claims and causes 67 | of action, whether now known or unknown (including existing as well as 68 | future claims and causes of action), in the Work (i) in all territories 69 | worldwide, (ii) for the maximum duration provided by applicable law or 70 | treaty (including future time extensions), (iii) in any current or future 71 | medium and for any number of copies, and (iv) for any purpose whatsoever, 72 | including without limitation commercial, advertising or promotional 73 | purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each 74 | member of the public at large and to the detriment of Affirmer's heirs and 75 | successors, fully intending that such Waiver shall not be subject to 76 | revocation, rescission, cancellation, termination, or any other legal or 77 | equitable action to disrupt the quiet enjoyment of the Work by the public 78 | as contemplated by Affirmer's express Statement of Purpose. 79 | 80 | 3. Public License Fallback. Should any part of the Waiver for any reason 81 | be judged legally invalid or ineffective under applicable law, then the 82 | Waiver shall be preserved to the maximum extent permitted taking into 83 | account Affirmer's express Statement of Purpose. In addition, to the 84 | extent the Waiver is so judged Affirmer hereby grants to each affected 85 | person a royalty-free, non transferable, non sublicensable, non exclusive, 86 | irrevocable and unconditional license to exercise Affirmer's Copyright and 87 | Related Rights in the Work (i) in all territories worldwide, (ii) for the 88 | maximum duration provided by applicable law or treaty (including future 89 | time extensions), (iii) in any current or future medium and for any number 90 | of copies, and (iv) for any purpose whatsoever, including without 91 | limitation commercial, advertising or promotional purposes (the 92 | "License"). The License shall be deemed effective as of the date CC0 was 93 | applied by Affirmer to the Work. Should any part of the License for any 94 | reason be judged legally invalid or ineffective under applicable law, such 95 | partial invalidity or ineffectiveness shall not invalidate the remainder 96 | of the License, and in such case Affirmer hereby affirms that he or she 97 | will not (i) exercise any of his or her remaining Copyright and Related 98 | Rights in the Work or (ii) assert any associated claims and causes of 99 | action with respect to the Work, in either case contrary to Affirmer's 100 | express Statement of Purpose. 101 | 102 | 4. Limitations and Disclaimers. 103 | 104 | a. No trademark or patent rights held by Affirmer are waived, abandoned, 105 | surrendered, licensed or otherwise affected by this document. 106 | b. Affirmer offers the Work as-is and makes no representations or 107 | warranties of any kind concerning the Work, express, implied, 108 | statutory or otherwise, including without limitation warranties of 109 | title, merchantability, fitness for a particular purpose, non 110 | infringement, or the absence of latent or other defects, accuracy, or 111 | the present or absence of errors, whether or not discoverable, all to 112 | the greatest extent permissible under applicable law. 113 | c. Affirmer disclaims responsibility for clearing rights of other persons 114 | that may apply to the Work or any use thereof, including without 115 | limitation any person's Copyright and Related Rights in the Work. 116 | Further, Affirmer disclaims responsibility for obtaining any necessary 117 | consents, permissions or other rights required for any use of the 118 | Work. 119 | d. Affirmer understands and acknowledges that Creative Commons is not a 120 | party to this document and has no duty or obligation with respect to 121 | this CC0 or use of the Work. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ErgoDEX contracts implementation for Cardano 2 | 3 | This repository contains implementations of the following scripts: 4 | * CFMM DEX scripts 5 | - Pool 6 | - Swap proxy 7 | - Deposit proxy 8 | - Redeem proxy 9 | 10 | ## Setting up 11 | 12 | ### Cabal+Nix build 13 | 14 | Alternatively, use the Cabal+Nix build if you want to develop with incremental builds, but also have it automatically download all dependencies. 15 | 16 | Set up your machine to build things with `Nix`, following the [Plutus README](https://github.com/input-output-hk/plutus/blob/master/README.adoc) (make sure to set up the binary cache!). 17 | 18 | To enter a development environment, simply open a terminal on the project's root and use `nix-shell` to get a bash shell: 19 | 20 | ``` 21 | $ nix-shell 22 | ``` 23 | 24 | Otherwise, you can use [direnv](https://github.com/direnv/direnv) which allows you to use your preferred shell. Once installed, just run: 25 | 26 | ``` 27 | $ echo "use nix" > .envrc # Or manually add "use nix" in .envrc if you already have one 28 | $ direnv allow 29 | ``` 30 | 31 | and you'll have a working development environment for now and the future whenever you enter this directory. 32 | 33 | The build should not take too long if you correctly set up the binary cache. If it starts building GHC, stop and setup the binary cache. 34 | 35 | Afterwards, the command `cabal build` from the terminal should work (if `cabal` couldn't resolve the dependencies, run `cabal update` and then `cabal build`). 36 | 37 | Also included in the environment is a working [Haskell Language Server](https://github.com/haskell/haskell-language-server) you can integrate with your editor. 38 | See [here](https://github.com/haskell/haskell-language-server#configuring-your-editor) for instructions. 39 | 40 | -------------------------------------------------------------------------------- /algebra-core/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /algebra-core/algebra-core.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: algebra-core 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: TypeOperators 21 | RankNTypes 22 | KindSignatures 23 | 24 | ghc-options: -Wall 25 | -Wcompat 26 | -Wincomplete-record-updates 27 | -Wincomplete-uni-patterns 28 | -Wpartial-fields 29 | -Wredundant-constraints 30 | -Wunused-packages 31 | -Widentities 32 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 33 | 34 | library 35 | import: base, project-config 36 | 37 | hs-source-dirs: src 38 | 39 | exposed-modules: Algebra.Natural -------------------------------------------------------------------------------- /algebra-core/src/Algebra/Natural.hs: -------------------------------------------------------------------------------- 1 | module Algebra.Natural 2 | ( type (~>) 3 | , FunctorK(..) 4 | ) where 5 | 6 | import Data.Kind (Type) 7 | 8 | type f ~> g = forall a. f a -> g a 9 | 10 | class FunctorK (alg :: (Type -> Type) -> Type) where 11 | fmapK :: (f ~> g) -> alg f -> alg g -------------------------------------------------------------------------------- /cardano-tx/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /cardano-tx/cardano-tx.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: cardano-tx 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | DerivingVia 23 | BangPatterns 24 | BinaryLiterals 25 | ConstraintKinds 26 | DataKinds 27 | DerivingStrategies 28 | DefaultSignatures 29 | DeriveDataTypeable 30 | DeriveFoldable 31 | DeriveFunctor 32 | DeriveGeneric 33 | DeriveTraversable 34 | DoAndIfThenElse 35 | DuplicateRecordFields 36 | EmptyDataDecls 37 | ExistentialQuantification 38 | FlexibleContexts 39 | FlexibleInstances 40 | FunctionalDependencies 41 | GADTs 42 | GeneralizedNewtypeDeriving 43 | InstanceSigs 44 | KindSignatures 45 | LambdaCase 46 | MultiParamTypeClasses 47 | MultiWayIf 48 | NamedFieldPuns 49 | PartialTypeSignatures 50 | PatternGuards 51 | PolyKinds 52 | RankNTypes 53 | RecordWildCards 54 | ScopedTypeVariables 55 | StandaloneDeriving 56 | TupleSections 57 | TypeFamilies 58 | TypeSynonymInstances 59 | ViewPatterns 60 | 61 | ghc-options: -Wall 62 | -Wcompat 63 | -Wincomplete-record-updates 64 | -Wincomplete-uni-patterns 65 | -Wpartial-fields 66 | -Wredundant-constraints 67 | -Wunused-packages 68 | -Widentities 69 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 70 | 71 | library 72 | import: base, project-config 73 | 74 | hs-source-dirs: src 75 | 76 | exposed-modules: CardanoTx.Models 77 | CardanoTx.Address 78 | CardanoTx.ToPlutus 79 | CardanoTx.Value 80 | CardanoTx.Interop 81 | CardanoTx.Types 82 | 83 | build-depends: 84 | mtl, 85 | plutus-chain-index, 86 | plutus-script-utils, 87 | plutus-chain-index-core, 88 | plutus-ledger-constraints, 89 | plutus-ledger, 90 | plutus-tx, 91 | plutus-ledger-api, 92 | bytestring, 93 | aeson, 94 | servant, 95 | singletons, 96 | either, 97 | aeson-gadt-th, 98 | some, 99 | dependent-sum-template, 100 | containers, 101 | freer-simple, 102 | plutus-core, 103 | extra, 104 | cardano-api, 105 | text -------------------------------------------------------------------------------- /cardano-tx/src/CardanoTx/Address.hs: -------------------------------------------------------------------------------- 1 | module CardanoTx.Address 2 | ( readShellyAddress 3 | ) where 4 | 5 | import Data.Text 6 | import Data.Either.Combinators 7 | 8 | import qualified Ledger as P 9 | import qualified Cardano.Api as C 10 | import qualified Ledger.Tx.CardanoAPI as Interop 11 | 12 | readShellyAddress :: Text -> Maybe P.Address 13 | readShellyAddress text = do 14 | saddr <- C.deserialiseAddress (C.AsAddress C.AsShelleyAddr) text 15 | rightToMaybe $ Interop.fromCardanoAddressInEra (C.shelleyAddressInEra saddr :: C.AddressInEra C.BabbageEra) 16 | -------------------------------------------------------------------------------- /cardano-tx/src/CardanoTx/Models.hs: -------------------------------------------------------------------------------- 1 | module CardanoTx.Models where 2 | 3 | import Data.Aeson (FromJSON, ToJSON) 4 | import qualified Data.Set as Set 5 | import qualified Data.Map as Map 6 | 7 | import Ledger hiding (TxIn) 8 | import Plutus.V1.Ledger.Credential (Credential (..)) 9 | import Plutus.Script.Utils.Scripts 10 | import qualified Ledger as P 11 | import qualified Plutus.V2.Ledger.Tx as PV2 12 | import GHC.Generics (Generic) 13 | 14 | import CardanoTx.ToPlutus (ToPlutus(..)) 15 | import Plutus.ChainIndex (OutputDatum) 16 | 17 | newtype ChangeAddress = ChangeAddress { getAddress :: Address } 18 | deriving (Eq, Generic) 19 | deriving newtype (Show, FromJSON, ToJSON) 20 | 21 | -- Defines how a residual value (if any) should be handled 22 | data ChangePolicy = ReturnTo Address 23 | deriving (Show, Eq, Generic, FromJSON, ToJSON) 24 | 25 | newtype MintValue = MintValue { unMintValue :: Value } 26 | deriving (Eq, Generic) 27 | deriving newtype (Show, FromJSON, ToJSON) 28 | deriving Semigroup via Value 29 | deriving Monoid via Value 30 | 31 | data TxOutDatum 32 | = KnownDatum Datum 33 | | KnownDatumHash DatumHash 34 | | EmptyDatum 35 | deriving (Show, Eq, Generic, FromJSON, ToJSON) 36 | 37 | asTxOutDatumHash :: TxOutDatum -> Maybe DatumHash 38 | asTxOutDatumHash (KnownDatum dt) = Just $ datumHash dt 39 | asTxOutDatumHash (KnownDatumHash dh) = Just dh 40 | asTxOutDatumHash _ = Nothing 41 | 42 | asTxOutDatum :: TxOutDatum -> OutputDatum 43 | asTxOutDatum (KnownDatum dt) = PV2.OutputDatum dt 44 | asTxOutDatum _ = PV2.NoOutputDatum 45 | 46 | -- TX output template 47 | data TxOutCandidate = TxOutCandidate 48 | { txOutCandidateAddress :: Address 49 | , txOutCandidateValue :: Value 50 | , txOutCandidateDatum :: TxOutDatum 51 | , txOutCandidateRefScript :: Maybe P.ScriptHash 52 | } 53 | deriving (Show, Eq, Generic, FromJSON, ToJSON) 54 | 55 | instance ToPlutus TxOutCandidate PV2.TxOut where 56 | toPlutus TxOutCandidate{..} = 57 | PV2.TxOut txOutCandidateAddress txOutCandidateValue dh Nothing 58 | where dh = asTxOutDatum txOutCandidateDatum 59 | 60 | instance Ord TxOutCandidate where 61 | compare TxOutCandidate{txOutCandidateAddress=rx} TxOutCandidate{txOutCandidateAddress=ry} = compare rx ry 62 | 63 | data FullTxOut = FullTxOut 64 | { fullTxOutRef :: TxOutRef 65 | , fullTxOutAddress :: Address 66 | , fullTxOutValue :: Value 67 | , fullTxOutDatum :: TxOutDatum 68 | , fullTxOutScriptRef :: Maybe P.ScriptHash 69 | } deriving (Show, Eq, Generic, FromJSON, ToJSON) 70 | 71 | mkFullTxOut :: TxOutRef -> TxOutCandidate -> FullTxOut 72 | mkFullTxOut ref TxOutCandidate{..} = 73 | FullTxOut ref txOutCandidateAddress txOutCandidateValue txOutCandidateDatum txOutCandidateRefScript 74 | 75 | instance ToPlutus FullTxOut PV2.TxOut where 76 | toPlutus FullTxOut{..} = PV2.TxOut fullTxOutAddress fullTxOutValue dh fullTxOutScriptRef 77 | where dh = asTxOutDatum fullTxOutDatum 78 | 79 | instance Ord FullTxOut where 80 | compare FullTxOut{fullTxOutRef=rx} FullTxOut{fullTxOutRef=ry} = compare rx ry 81 | 82 | data FullTxIn = FullTxIn 83 | { fullTxInTxOut :: FullTxOut 84 | , fullTxInType :: TxInType 85 | } deriving (Show, Eq, Generic, FromJSON, ToJSON) 86 | 87 | instance Ord FullTxIn where 88 | compare FullTxIn{fullTxInTxOut=foutx} FullTxIn{fullTxInTxOut=fouty} = compare foutx fouty 89 | 90 | mkPkhTxIn :: FullTxOut -> FullTxIn 91 | mkPkhTxIn fout = FullTxIn fout ConsumePublicKeyAddress 92 | 93 | mkScriptTxIn :: FullTxOut -> Validator -> Redeemer -> FullTxIn 94 | mkScriptTxIn fout@FullTxOut{..} v r = 95 | FullTxIn fout $ case (fullTxOutAddress, fullTxOutDatum) of 96 | (Address (ScriptCredential _) _, KnownDatum d) -> ConsumeScriptAddress PlutusV2 v r d 97 | _ -> ConsumeScriptAddress PlutusV2 v r unitDatum 98 | 99 | instance ToPlutus FullTxIn P.TxIn where 100 | toPlutus FullTxIn{..} = 101 | P.TxIn (fullTxOutRef fullTxInTxOut) $ Just fullTxInType 102 | 103 | data FullCollateralTxIn = FullCollateralTxIn 104 | { fullCollateralTxInTxOut :: FullTxOut 105 | } deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON) 106 | 107 | instance ToPlutus FullCollateralTxIn P.TxIn where 108 | toPlutus FullCollateralTxIn{fullCollateralTxInTxOut=FullTxOut{..}} = 109 | P.TxIn fullTxOutRef $ Just P.ConsumePublicKeyAddress 110 | 111 | data MintInputs = MintInputs 112 | { mintInputsPolicies :: Set.Set MintingPolicy 113 | , mintInputsRedeemers :: Map.Map Integer Redeemer 114 | } deriving (Show, Eq, Generic, FromJSON, ToJSON) 115 | 116 | instance Semigroup MintInputs where 117 | (<>) (MintInputs lInputs lRedeemers) (MintInputs rInputs rRedeemers) = 118 | MintInputs 119 | { mintInputsPolicies = lInputs <> rInputs 120 | , mintInputsRedeemers = lRedeemers <> rRedeemers 121 | } 122 | 123 | instance Monoid MintInputs where 124 | mempty = 125 | MintInputs 126 | { mintInputsPolicies = Set.empty 127 | , mintInputsRedeemers = Map.empty 128 | } 129 | 130 | mkMintInputs :: [(MintingPolicy, Redeemer)] -> MintInputs 131 | mkMintInputs xs = MintInputs mps rs 132 | where (mps, rs) = foldr (\ (ix, (mp, r)) (mpsa, rsa) -> (Set.insert mp mpsa, Map.insert ix r rsa)) (mempty, mempty) (zip [0..] xs) 133 | 134 | -- TX template without collaterals, fees, change etc. 135 | data TxCandidate = TxCandidate 136 | { txCandidateInputs :: Set.Set FullTxIn 137 | , txCandidateRefIns :: [FullTxOut] -- we are not going to consume those inputs, so they are represented as FullTxOut 138 | , txCandidateOutputs :: [TxOutCandidate] 139 | , txCandidateValueMint :: MintValue 140 | , txCandidateMintInputs :: MintInputs 141 | , txCandidateChangePolicy :: Maybe ChangePolicy 142 | , txCandidateValidRange :: SlotRange 143 | , txCandidateSigners :: [PaymentPubKeyHash] 144 | } deriving (Show, Eq, Generic, FromJSON, ToJSON) -------------------------------------------------------------------------------- /cardano-tx/src/CardanoTx/ToPlutus.hs: -------------------------------------------------------------------------------- 1 | module CardanoTx.ToPlutus where 2 | 3 | class ToPlutus a p where 4 | toPlutus :: a -> p 5 | 6 | class FromPlutus a p where 7 | fromPlutus :: p -> a 8 | -------------------------------------------------------------------------------- /cardano-tx/src/CardanoTx/Types.hs: -------------------------------------------------------------------------------- 1 | module CardanoTx.Types where 2 | 3 | import qualified Data.Text as T 4 | import Data.Aeson (FromJSON, ToJSON) 5 | import GHC.Generics (Generic) 6 | 7 | -- TX hash32 represented as a hex string 8 | newtype TxHash = TxHash { unTxHash :: T.Text } 9 | deriving (Eq, Generic) 10 | deriving newtype (Show, FromJSON) 11 | 12 | -- Block hash32 represented as a hex string 13 | newtype BlockHash = BlockHash { unBlockHash :: T.Text } 14 | deriving (Eq, Generic) 15 | deriving newtype (Show, FromJSON) -------------------------------------------------------------------------------- /cardano-tx/src/CardanoTx/Value.hs: -------------------------------------------------------------------------------- 1 | module CardanoTx.Value where 2 | 3 | import qualified Data.Map as HMap 4 | import qualified PlutusTx.AssocMap as Map 5 | import Plutus.V1.Ledger.Value 6 | 7 | unionVal :: Value -> Value -> Value 8 | unionVal (Value l) (Value r) = 9 | let 10 | all2list = (fmap (\(a, b) -> (a, Map.toList b)) ( (Map.toList l) ++ (Map.toList r))) 11 | commonMap = HMap.fromListWith (++) all2list 12 | in Value $ Map.fromList $ fmap (\(a, b) -> (a, Map.fromList b)) (HMap.toList commonMap) -------------------------------------------------------------------------------- /datum-keeper-client/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /datum-keeper-client/datum-keeper-client.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: datum-keeper-client 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | BangPatterns 23 | BinaryLiterals 24 | ConstraintKinds 25 | DataKinds 26 | DefaultSignatures 27 | DeriveDataTypeable 28 | DeriveFoldable 29 | DeriveFunctor 30 | DeriveGeneric 31 | DeriveTraversable 32 | DoAndIfThenElse 33 | EmptyDataDecls 34 | ExistentialQuantification 35 | FlexibleContexts 36 | FlexibleInstances 37 | FunctionalDependencies 38 | GADTs 39 | GeneralizedNewtypeDeriving 40 | InstanceSigs 41 | KindSignatures 42 | LambdaCase 43 | MultiParamTypeClasses 44 | MultiWayIf 45 | NamedFieldPuns 46 | PartialTypeSignatures 47 | PatternGuards 48 | PolyKinds 49 | RankNTypes 50 | RecordWildCards 51 | ScopedTypeVariables 52 | StandaloneDeriving 53 | TupleSections 54 | TypeFamilies 55 | TypeSynonymInstances 56 | ViewPatterns 57 | 58 | ghc-options: -Wall 59 | -Wcompat 60 | -Wincomplete-record-updates 61 | -Wincomplete-uni-patterns 62 | -Wpartial-fields 63 | -Wredundant-constraints 64 | -Wunused-packages 65 | -Widentities 66 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 67 | 68 | library 69 | import: base, project-config 70 | 71 | hs-source-dirs: src 72 | 73 | exposed-modules: DatumKeeper.Config.KeeperConfig 74 | DatumKeeper.Client 75 | 76 | build-depends: 77 | plutus-ledger, 78 | plutus-tx, 79 | plutus-ledger-api, 80 | bytestring, 81 | aeson, 82 | servant, 83 | singletons, 84 | some, 85 | containers, 86 | plutus-core, 87 | extra, 88 | cardano-api, 89 | text, 90 | http-conduit, 91 | rio==0.1.21.0 -------------------------------------------------------------------------------- /datum-keeper-client/src/DatumKeeper/Client.hs: -------------------------------------------------------------------------------- 1 | module DatumKeeper.Client where 2 | 3 | import RIO 4 | import Network.HTTP.Simple 5 | import Data.Aeson 6 | import DatumKeeper.Config.KeeperConfig 7 | import Data.ByteString.Char8 8 | import GHC.Natural 9 | import Ledger 10 | 11 | data KeeperClient f = KeeperClient 12 | { putDatum :: Datum -> f () 13 | } 14 | 15 | makeKeeperClient :: (MonadIO f) => DatumKeeperConfig -> KeeperClient f 16 | makeKeeperClient config = KeeperClient (putDatum' config) 17 | 18 | putDatum' :: (MonadIO f) => DatumKeeperConfig -> Datum -> f () 19 | putDatum' DatumKeeperConfig{..} datum = do 20 | let 21 | request = defaultRequest 22 | & setRequestPath (pack "put") 23 | & setRequestHost (pack host) 24 | & setRequestPort (naturalToInt port) 25 | & setRequestMethod (pack "POST") 26 | & setRequestBodyJSON (toJSON datum) 27 | 28 | response <- liftIO $ httpJSON request 29 | 30 | pure $ getResponseBody response -------------------------------------------------------------------------------- /datum-keeper-client/src/DatumKeeper/Config/KeeperConfig.hs: -------------------------------------------------------------------------------- 1 | module DatumKeeper.Config.KeeperConfig where 2 | 3 | import GHC.Natural 4 | 5 | data DatumKeeperConfig = DatumKeeperConfig 6 | { host :: String 7 | , port :: Natural 8 | } -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # default.nix -- The top-level nix build file for cardano-dex-sdk. 3 | # 4 | # This file defines various attributes that are used for building and 5 | # developing cardano-dex-sdk. 6 | # 7 | ######################################################################## 8 | 9 | let 10 | # Here a some of the various attributes for the variable 'packages': 11 | # 12 | # { pkgs 13 | # cardano-dex-sdk: { 14 | # haskell: { 15 | # project # The Haskell project created by haskell-nix.project 16 | # packages # All the packages defined by our project, including dependencies 17 | # projectPackages # Just the packages in the project 18 | # } 19 | # hlint 20 | # cabal-install 21 | # stylish-haskell 22 | # haskell-language-server 23 | # } 24 | # } 25 | packages = import ./nix; 26 | 27 | inherit (packages) pkgs cardano-dex-sdk; 28 | project = cardano-dex-sdk.haskell.project; 29 | in 30 | { 31 | inherit pkgs cardano-dex-sdk; 32 | 33 | inherit project; 34 | } 35 | -------------------------------------------------------------------------------- /dex-core/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /dex-core/dex-core.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: dex-core 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | BangPatterns 23 | BinaryLiterals 24 | ConstraintKinds 25 | DataKinds 26 | DefaultSignatures 27 | DeriveDataTypeable 28 | DeriveFoldable 29 | DeriveFunctor 30 | DeriveGeneric 31 | DeriveTraversable 32 | DerivingStrategies 33 | UndecidableInstances 34 | DoAndIfThenElse 35 | EmptyDataDecls 36 | ExistentialQuantification 37 | LambdaCase 38 | FlexibleContexts 39 | FlexibleInstances 40 | FunctionalDependencies 41 | GADTs 42 | GeneralizedNewtypeDeriving 43 | InstanceSigs 44 | KindSignatures 45 | LambdaCase 46 | MultiParamTypeClasses 47 | MultiWayIf 48 | NamedFieldPuns 49 | PartialTypeSignatures 50 | PatternGuards 51 | PolyKinds 52 | RankNTypes 53 | LambdaCase 54 | RecordWildCards 55 | ScopedTypeVariables 56 | StandaloneDeriving 57 | TupleSections 58 | TypeApplications 59 | TypeFamilies 60 | TypeSynonymInstances 61 | ViewPatterns 62 | 63 | ghc-options: -Wall 64 | -Wcompat 65 | -Wincomplete-record-updates 66 | -Wincomplete-uni-patterns 67 | -Wpartial-fields 68 | -Wredundant-constraints 69 | -Wunused-packages 70 | -Widentities 71 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 72 | 73 | library 74 | import: base, project-config 75 | 76 | hs-source-dirs: src 77 | 78 | exposed-modules: ErgoDex.Class 79 | ErgoDex.Types 80 | ErgoDex.Validators 81 | ErgoDex.State 82 | ErgoDex.Amm.Orders 83 | ErgoDex.Amm.Pool 84 | ErgoDex.Amm.PoolActions 85 | ErgoDex.Amm.PoolSetup 86 | ErgoDex.Amm.Constants 87 | ErgoDex.ScriptsValidators 88 | 89 | build-depends: 90 | rio, 91 | cardano-tx, 92 | ergo-hs-common, 93 | plutus-ledger, 94 | plutus-tx, 95 | plutus-ledger-api, 96 | bytestring, 97 | aeson, 98 | servant, 99 | plutus-contract, 100 | mtl, 101 | cardano-dex-contracts-offchain, 102 | plutus-script-utils, 103 | singletons, 104 | transformers-either, 105 | aeson-gadt-th, 106 | some, 107 | dependent-sum-template, 108 | containers, 109 | freer-simple, 110 | plutus-core, 111 | either, 112 | extra, 113 | transformers, 114 | cardano-api, 115 | text, 116 | serialise, 117 | dhall, 118 | hlog 119 | 120 | test-suite dex-core-tests 121 | type: exitcode-stdio-1.0 122 | main-is: Main.hs 123 | hs-source-dirs: test 124 | other-modules: 125 | Spec.Pool 126 | build-depends: 127 | , base 128 | , HUnit 129 | , hedgehog 130 | , tasty-hunit 131 | , tasty 132 | , tasty-hedgehog 133 | , text 134 | , base16-bytestring 135 | , bytestring 136 | , plutus-ledger-api 137 | , random 138 | , plutus-tx 139 | , cardano-dex-contracts-offchain 140 | , plutus-ledger-api 141 | , plutus-ledger 142 | , containers 143 | , random-strings 144 | , plutus-core 145 | , dex-core 146 | , cardano-tx 147 | -------------------------------------------------------------------------------- /dex-core/src/ErgoDex/Amm/Constants.hs: -------------------------------------------------------------------------------- 1 | module ErgoDex.Amm.Constants where 2 | 3 | import Ledger.Ada (lovelaceValueOf) 4 | import Ledger.Value (Value) 5 | import ErgoDex.Contracts.Types (Amount(..), Lovelace) 6 | 7 | minSafeOutputAmount :: Amount Lovelace 8 | minSafeOutputAmount = Amount 3000000 9 | 10 | minSafeOutputValue:: Value 11 | minSafeOutputValue = lovelaceValueOf $ unAmount minSafeOutputAmount 12 | -------------------------------------------------------------------------------- /dex-core/src/ErgoDex/Amm/PoolSetup.hs: -------------------------------------------------------------------------------- 1 | module ErgoDex.Amm.PoolSetup where 2 | 3 | import qualified Data.Set as Set 4 | import RIO 5 | import Control.Monad.Trans.Either (hoistEither, runEitherT) 6 | import Control.Monad.Trans.Except (ExceptT(ExceptT)) 7 | 8 | import Ledger (Address, StakePubKeyHash, PaymentPubKeyHash, pubKeyHashAddress) 9 | import qualified Ledger.Interval as Interval 10 | import Ledger.Value (AssetClass) 11 | 12 | import ErgoDex.Types 13 | import ErgoDex.State 14 | import ErgoDex.Validators 15 | import ErgoDex.Amm.Pool (Pool(..), initPool) 16 | import ErgoDex.Amm.Constants 17 | import qualified ErgoDex.Contracts.Typed as P 18 | import ErgoDex.Contracts.Types 19 | import CardanoTx.Models 20 | import ErgoDex.Contracts.Pool (maxLqCapAmount) 21 | 22 | data SetupExecError = 23 | MissingAsset AssetClass 24 | | MissingPool 25 | | InvalidNft 26 | | InvalidLiquidity 27 | | InsufficientInputs 28 | deriving Show 29 | 30 | data PoolSetup = PoolSetup 31 | { poolDeploy 32 | :: PaymentPubKeyHash 33 | -> Maybe StakePubKeyHash 34 | -> P.PoolConfig 35 | -> [FullTxOut] 36 | -> Either SetupExecError TxCandidate 37 | } 38 | 39 | burnLqInitial :: Amount Liquidity 40 | burnLqInitial = Amount 1000 -- todo: aggregate protocol constants 41 | 42 | mkPoolSetup :: PoolValidatorV1 -> Address -> PoolSetup 43 | mkPoolSetup pv changeAddr = PoolSetup 44 | { poolDeploy = poolDeploy' pv burnLqInitial changeAddr 45 | } 46 | 47 | poolDeploy' 48 | :: PoolValidatorV1 49 | -> Amount Liquidity 50 | -> Address 51 | -> PaymentPubKeyHash 52 | -> Maybe StakePubKeyHash 53 | -> P.PoolConfig 54 | -> [FullTxOut] 55 | -> Either SetupExecError TxCandidate 56 | poolDeploy' pv burnLq changeAddr rewardPkh stakePkh pp@P.PoolConfig{..} utxosIn = do 57 | inNft <- overallAmountOf utxosIn poolNft 58 | inLq <- overallAmountOf utxosIn poolLq 59 | inX <- overallAmountOf utxosIn poolX 60 | inY <- overallAmountOf utxosIn poolY 61 | 62 | unless (amountEq inNft 1) (Left InvalidNft) -- make sure valid NFT is provided 63 | unless (getAmount inLq == maxLqCapAmount) (Left InvalidLiquidity) -- make sure valid amount of LQ tokens is provided 64 | 65 | (Predicted poolOutput nextPool, unlockedLq) <- 66 | mapLeft (const InvalidLiquidity) (initPool pv pp burnLq (getAmount inX, getAmount inY)) 67 | 68 | let 69 | mintLqValue = coinAmountValue (poolCoinLq nextPool) unlockedLq 70 | rewardOutput = TxOutCandidate 71 | { txOutCandidateAddress = pubKeyHashAddress rewardPkh stakePkh 72 | , txOutCandidateValue = mintLqValue <> minSafeOutputValue 73 | , txOutCandidateDatum = EmptyDatum 74 | } 75 | 76 | inputs = utxosIn <&> mkPkhTxIn 77 | outputs = [poolOutput, rewardOutput] 78 | 79 | overallAdaOut = assetAmountOfCoin totalValueIn adaCoin 80 | where totalValueIn = foldr ( (<>) . txOutCandidateValue) mempty outputs 81 | 82 | overallAdaIn <- overallAmountOf utxosIn adaCoin 83 | unless (overallAdaIn >= overallAdaOut) (Left InsufficientInputs) 84 | 85 | Right $ TxCandidate 86 | { txCandidateInputs = Set.fromList inputs 87 | , txCandidateOutputs = [poolOutput, rewardOutput] 88 | , txCandidateValueMint = mempty -- todo: mint NFT and LQ right there? 89 | , txCandidateMintInputs = mempty 90 | , txCandidateChangePolicy = Just $ ReturnTo changeAddr 91 | , txCandidateValidRange = Interval.always 92 | , txCandidateSigners = mempty 93 | } 94 | 95 | overallAmountOf :: [FullTxOut] -> Coin a -> Either SetupExecError (AssetAmount a) 96 | overallAmountOf utxos c = 97 | if amountEq coinAmount 0 98 | then Left $ MissingAsset $ unCoin c 99 | else Right coinAmount 100 | where 101 | totalValueIn = foldr ( (<>) . fullTxOutValue) mempty utxos 102 | coinAmount = assetAmountOfCoin totalValueIn c 103 | -------------------------------------------------------------------------------- /dex-core/src/ErgoDex/Class.hs: -------------------------------------------------------------------------------- 1 | module ErgoDex.Class where 2 | 3 | import CardanoTx.Models 4 | import ErgoDex.State 5 | 6 | class FromLedger a where 7 | parseFromLedger :: FullTxOut -> Maybe (OnChain a) 8 | 9 | class ToLedger ctx a where 10 | toLedger :: ctx -> a -> TxOutCandidate -------------------------------------------------------------------------------- /dex-core/src/ErgoDex/ScriptsValidators.hs: -------------------------------------------------------------------------------- 1 | module ErgoDex.ScriptsValidators where 2 | 3 | import Codec.Serialise 4 | ( deserialise ) 5 | import RIO 6 | ( MonadIO (liftIO), Generic ) 7 | import Dhall 8 | ( FromDhall, input, auto ) 9 | 10 | import qualified Data.ByteString.Lazy as BSL 11 | 12 | import qualified Plutus.V2.Ledger.Api as PV2 13 | 14 | import ErgoDex.Amm.PoolActions 15 | ( AmmValidators (..) ) 16 | import ErgoDex.Validators 17 | ( V1, PoolValidator (..), OrderValidator (..) ) 18 | import System.Logging.Hlog 19 | import CardanoTx.Models (FullTxOut(..)) 20 | import ErgoDex.State (Confirmed(Confirmed), OnChain (OnChain)) 21 | import ErgoDex.Amm.Pool (Pool(Pool)) 22 | import ErgoDex.Class (parseFromLedger) 23 | import Plutus.Script.Utils.V2.Address (mkValidatorAddress) 24 | 25 | data ScriptsConfig = ScriptsConfig 26 | { swapScriptPath :: !FilePath 27 | , depositScriptPath :: !FilePath 28 | , redeemScriptPath :: !FilePath 29 | , poolScriptPath :: !FilePath 30 | } deriving (Generic, FromDhall) 31 | 32 | data ScriptsValidators = ScriptsValidators 33 | { swapValidator :: PV2.Validator 34 | , depositValidator :: PV2.Validator 35 | , redeemValidator :: PV2.Validator 36 | , poolValidator :: PV2.Validator 37 | } 38 | 39 | parsePool :: (MonadIO m) => Logging m -> ScriptsValidators -> FullTxOut -> m (Maybe (Confirmed (OnChain Pool))) 40 | parsePool Logging{..} ScriptsValidators{poolValidator} out@FullTxOut{..} = do 41 | let 42 | pool = parseFromLedger out :: Maybe (OnChain Pool) 43 | poolAddress = mkValidatorAddress poolValidator 44 | if fullTxOutAddress == poolAddress 45 | then case pool of 46 | Just a -> do 47 | infoM ("Pool found in: " ++ show out) 48 | pure $ Just $ Confirmed out a 49 | _ -> do 50 | infoM ("Pool not found in: " ++ show out) 51 | pure Nothing 52 | else pure Nothing 53 | 54 | mkScriptsValidators :: (MonadIO m) => ScriptsConfig -> m ScriptsValidators 55 | mkScriptsValidators ScriptsConfig{..} = do 56 | swapValidator <- readValidatorFromFile swapScriptPath 57 | redeemValidator <- readValidatorFromFile redeemScriptPath 58 | depositValidator <- readValidatorFromFile depositScriptPath 59 | poolValidator <- readValidatorFromFile poolScriptPath 60 | pure $ ScriptsValidators{..} 61 | 62 | readValidatorFromFile :: (MonadIO m) => FilePath -> m PV2.Validator 63 | readValidatorFromFile path = do 64 | bytes <- liftIO $ BSL.readFile path 65 | pure $ deserialise bytes 66 | -------------------------------------------------------------------------------- /dex-core/src/ErgoDex/State.hs: -------------------------------------------------------------------------------- 1 | module ErgoDex.State where 2 | 3 | import Data.Aeson (FromJSON, ToJSON) 4 | import GHC.Generics (Generic) 5 | import CardanoTx.Models 6 | 7 | -- An on-chain entity `a` 8 | data OnChain a = OnChain FullTxOut a 9 | deriving (Show, Eq, Generic, FromJSON, ToJSON) 10 | 11 | -- Predicted state of an on-chain entity `a` 12 | data Predicted a = Predicted TxOutCandidate a 13 | deriving (Show, Eq, Generic, FromJSON, ToJSON) 14 | 15 | -- Confirmed state of an on-chain entity `a` 16 | data Confirmed a = Confirmed FullTxOut a 17 | deriving (Show, Eq, Generic, FromJSON, ToJSON) 18 | -------------------------------------------------------------------------------- /dex-core/src/ErgoDex/Types.hs: -------------------------------------------------------------------------------- 1 | module ErgoDex.Types where 2 | 3 | import Prelude (Show, Eq, Ord(..), Integer, Bool, ($), (==), (<>), negate) 4 | import Data.Aeson (FromJSON, ToJSON) 5 | import GHC.Generics (Generic) 6 | 7 | import Ledger 8 | import qualified Ledger.Ada as Ada 9 | import Ledger.Value (AssetClass(..), assetClassValueOf, assetClassValue, Value(..)) 10 | import PlutusTx.Numeric (AdditiveSemigroup(..), MultiplicativeSemigroup(..)) 11 | import qualified PlutusTx.AssocMap as Map 12 | 13 | import ErgoDex.Contracts.Types as Currencies 14 | 15 | --todo: move to orphans 16 | deriving anyclass instance ToJSON (Coin a) 17 | deriving anyclass instance FromJSON (Coin a) 18 | 19 | newtype AssetEntry = AssetEntry { unAssetEntry :: (AssetClass, Integer) } 20 | deriving (Show, Eq, Generic) 21 | deriving newtype (ToJSON, FromJSON) 22 | 23 | assetEntryClass :: AssetEntry -> AssetClass 24 | assetEntryClass (AssetEntry (cls, _)) = cls 25 | 26 | assetEntry :: CurrencySymbol -> TokenName -> Integer -> AssetEntry 27 | assetEntry cs tn v = AssetEntry (AssetClass (cs, tn), v) 28 | 29 | data AssetAmount a = AssetAmount 30 | { getAsset :: Coin a 31 | , getAmount :: Amount a 32 | } deriving (Generic, Show, Eq, ToJSON, FromJSON) 33 | 34 | instance AdditiveSemigroup (AssetAmount a) where 35 | a0 + a1 = a0 { getAmount = (getAmount a0) + (getAmount a1) } 36 | 37 | instance MultiplicativeSemigroup (AssetAmount a) where 38 | a0 * a1 = a0 { getAmount = (getAmount a0) * (getAmount a1) } 39 | 40 | instance Ord (AssetAmount a) where 41 | compare (AssetAmount _ (Amount x)) (AssetAmount _ (Amount y)) = compare x y 42 | 43 | amountEq :: AssetAmount a -> Integer -> Bool 44 | amountEq (AssetAmount _ (Amount a)) b = a == b 45 | 46 | assetAmountSubtract :: Value -> AssetAmount a -> Value 47 | assetAmountSubtract vl AssetAmount{getAsset=Coin ac, getAmount=Amount v} = 48 | vl <> negValue 49 | where 50 | (cs, tn) = unAssetClass ac 51 | negValue = Value $ Map.fromList [(cs, Map.fromList [(tn, negate v)])] 52 | 53 | assetAmountRawValue :: AssetAmount a -> Integer 54 | assetAmountRawValue AssetAmount{getAmount=Amount v} = v 55 | 56 | assetAmountValue :: AssetAmount a -> Value 57 | assetAmountValue AssetAmount{getAsset=Coin ac, getAmount=Amount v} = assetClassValue ac v 58 | 59 | assetAmountOf :: AssetEntry -> AssetAmount a 60 | assetAmountOf (AssetEntry (ac, v)) = AssetAmount (Coin ac) (Amount v) 61 | 62 | assetAmountCoinOf :: Coin a -> Integer -> AssetAmount a 63 | assetAmountCoinOf c v = AssetAmount c (Amount v) 64 | 65 | assetAmountPairOf :: (AssetEntry, AssetEntry) -> Coin a -> AssetAmount a 66 | assetAmountPairOf (AssetEntry (ac, av), AssetEntry (bc, bv)) c = 67 | AssetAmount c (Amount $ 68 | if ac == unCoin c then av 69 | else if bc == unCoin c then bv 70 | else 0) 71 | 72 | assetAmountOfCoin :: Value -> Coin a -> AssetAmount a 73 | assetAmountOfCoin v c = 74 | AssetAmount c (Amount $ assetClassValueOf v (unCoin c)) 75 | 76 | retagAmount :: forall a b. Amount a -> Amount b 77 | retagAmount (Amount x) = Amount x 78 | 79 | adaCoin :: Coin Lovelace 80 | adaCoin = Coin $ AssetClass (Ada.adaSymbol, Ada.adaToken ) 81 | 82 | data ExFeePerToken = ExFeePerToken 83 | { exFeePerTokenNum :: Integer 84 | , exFeePerTokenDen :: Integer 85 | } deriving (Show, Eq, Generic, ToJSON, FromJSON) 86 | 87 | newtype ExFee = ExFee { unExFee :: Amount Currencies.Lovelace } 88 | deriving (Show, Eq, Generic, ToJSON, FromJSON) 89 | -------------------------------------------------------------------------------- /dex-core/src/ErgoDex/Validators.hs: -------------------------------------------------------------------------------- 1 | module ErgoDex.Validators 2 | ( V1 3 | , PoolValidator(..) 4 | , OrderValidator(..) 5 | , orderValidator 6 | , type AnyOrderValidator 7 | , type SwapValidator 8 | , type DepositValidator 9 | , type RedeemValidator 10 | , type PoolValidatorV1 11 | , fetchPoolValidatorV1 12 | , fetchSwapValidatorV1 13 | , fetchDepositValidatorV1 14 | , fetchRedeemValidatorV1 15 | ) where 16 | 17 | import Control.Monad.IO.Class (MonadIO) 18 | import RIO ((<&>)) 19 | 20 | import qualified Plutus.V2.Ledger.Api as PV2 21 | 22 | import ErgoDex.PValidators 23 | 24 | newtype PoolValidator ver = PoolValidator PV2.Validator 25 | 26 | data V1 27 | 28 | data SwapK 29 | data DepositK 30 | data RedeemK 31 | 32 | data OrderValidator kind ver where 33 | SwapValidator :: PV2.Validator -> OrderValidator SwapK ver 34 | DepositValidator :: PV2.Validator -> OrderValidator DepositK ver 35 | RedeemValidator :: PV2.Validator -> OrderValidator RedeemK ver 36 | 37 | type SwapValidator ver = OrderValidator SwapK ver 38 | type DepositValidator ver = OrderValidator DepositK ver 39 | type RedeemValidator ver = OrderValidator RedeemK ver 40 | 41 | orderValidator :: OrderValidator kind ver -> PV2.Validator 42 | orderValidator (SwapValidator sv) = sv 43 | orderValidator (DepositValidator dv) = dv 44 | orderValidator (RedeemValidator rv) = rv 45 | 46 | type AnyOrderValidator ver = forall kind. OrderValidator kind ver 47 | 48 | type PoolValidatorV1 = PoolValidator V1 49 | 50 | fetchPoolValidatorV1 :: MonadIO m => m (PoolValidator V1) 51 | fetchPoolValidatorV1 = poolValidator <&> PoolValidator 52 | 53 | fetchSwapValidatorV1 :: MonadIO m => m (SwapValidator V1) 54 | fetchSwapValidatorV1 = swapValidator <&> SwapValidator 55 | 56 | fetchDepositValidatorV1 :: MonadIO m => m (DepositValidator V1) 57 | fetchDepositValidatorV1 = depositValidator <&> DepositValidator 58 | 59 | fetchRedeemValidatorV1 :: MonadIO m => m (RedeemValidator V1) 60 | fetchRedeemValidatorV1 = redeemValidator <&> RedeemValidator 61 | -------------------------------------------------------------------------------- /dex-core/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Text.Encoding as E 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | 8 | import Spec.Pool as PS 9 | 10 | main :: IO () 11 | main = do 12 | defaultMain tests 13 | 14 | tests = testGroup "DexCore" 15 | [ PS.toFromLedgerPoolTests 16 | , PS.checkDeposit 17 | , PS.checkRedeem 18 | , PS.checkSwap 19 | , PS.initialLiquidityTests 20 | , PS.initPoolTests 21 | ] 22 | -------------------------------------------------------------------------------- /dex-core/test/Spec/Pool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Spec.Pool 4 | ( initialLiquidityTests 5 | , initPoolTests 6 | , toFromLedgerPoolTests 7 | , checkDeposit 8 | , checkRedeem 9 | , checkSwap 10 | ) where 11 | 12 | import qualified Data.ByteString as BS 13 | 14 | import Control.Monad.IO.Class (MonadIO) 15 | 16 | import Hedgehog 17 | 18 | import Test.Tasty 19 | import Test.Tasty.HUnit 20 | import Test.Tasty.Hedgehog as HH 21 | 22 | import Data.List 23 | import Data.Ord 24 | 25 | import PlutusTx.Builtins.Internal (BuiltinByteString(..)) 26 | import Plutus.V1.Ledger.Api (CurrencySymbol(..), TokenName(..), toBuiltinData, TxOutRef(..)) 27 | import Plutus.V1.Ledger.Value (AssetClass(..)) 28 | 29 | import CardanoTx.Models (TxOutCandidate(..), mkFullTxOut) 30 | import ErgoDex.Amm.Pool 31 | import qualified ErgoDex.Contracts.Typed as S 32 | import ErgoDex.Contracts.Types 33 | import ErgoDex.Types 34 | import ErgoDex.State 35 | import ErgoDex.Validators 36 | import ErgoDex.Amm.PoolSetup (burnLqInitial) 37 | import ErgoDex.Class (ToLedger(toLedger), FromLedger(parseFromLedger)) 38 | import ErgoDex.Amm.Constants (minSafeOutputAmount) 39 | 40 | mkTokenName :: BS.ByteString -> TokenName 41 | mkTokenName = TokenName . BuiltinByteString 42 | 43 | mkCurrencySymbol :: BS.ByteString -> CurrencySymbol 44 | mkCurrencySymbol = CurrencySymbol . BuiltinByteString 45 | 46 | mkAssetClass :: BS.ByteString -> BS.ByteString -> AssetClass 47 | mkAssetClass cs tn = AssetClass (mkCurrencySymbol cs, mkTokenName tn) 48 | 49 | poolNft :: Coin Nft 50 | poolNft = Coin $ mkAssetClass "nft" "pool_nft" 51 | 52 | poolX :: Coin X 53 | poolX = Coin $ mkAssetClass "x" "pool_x" 54 | 55 | poolY :: Coin Y 56 | poolY = Coin $ mkAssetClass "y" "pool_y" 57 | 58 | poolLq :: Coin Liquidity 59 | poolLq = Coin $ mkAssetClass "lq" "pool_lq" 60 | 61 | baseX :: Coin Base 62 | baseX = Coin $ mkAssetClass "x" "pool_x" 63 | 64 | baseY :: Coin Base 65 | baseY = Coin $ mkAssetClass "y" "pool_y" 66 | 67 | quoteX :: Coin Quote 68 | quoteX = Coin $ mkAssetClass "x" "pool_x" 69 | 70 | quoteY :: Coin Quote 71 | quoteY = Coin $ mkAssetClass "y" "pool_y" 72 | 73 | poolFeeNum = 995 74 | 75 | initialLiquidityTests = testGroup "InitialLiquidity" 76 | [ testCase "initial_liquidity_exact" $ 77 | initialLiquidityAmount poolLq (Amount 10, Amount 10) @?= Right (AssetAmount poolLq 10) 78 | 79 | , testCase "initial_liquidity_approximated" $ 80 | initialLiquidityAmount poolLq (Amount 10, Amount 11) @?= Right (AssetAmount poolLq 11) 81 | ] 82 | 83 | poolConf = S.PoolConfig poolNft poolX poolY poolLq poolFeeNum 84 | 85 | sufficientInitDepositX = Amount 800 86 | 87 | insufficientInitDepositX = Amount 500 88 | 89 | initDepositY = Amount 2000 90 | 91 | releasedLq = Amount 265 92 | 93 | nativePool = Pool 94 | { poolId = PoolId poolNft 95 | , poolReservesX = sufficientInitDepositX 96 | , poolReservesY = initDepositY 97 | , poolLiquidity = releasedLq 98 | , poolCoinX = poolX 99 | , poolCoinY = poolY 100 | , poolCoinLq = poolLq 101 | , poolFee = PoolFee poolFeeNum feeDen 102 | , outCollateral = minSafeOutputAmount 103 | } 104 | 105 | initPoolTests = testGroup "NonNativePoolInit" 106 | [ HH.testProperty "init_non_native_pool_sufficient_liquidity" initNonNativePoolSufficientLiquidity 107 | , HH.testProperty "init_non_native_pool_insufficient_liquidity" initNonNativePoolInsufficientLiquidity 108 | ] 109 | 110 | initNonNativePoolInsufficientLiquidity :: Property 111 | initNonNativePoolInsufficientLiquidity = property $ do 112 | pv <- fetchPoolValidatorV1 113 | let pool = initPool pv poolConf burnLqInitial (insufficientInitDepositX, initDepositY) 114 | pool === Left (InsufficientInitialLiqudity $ Amount 1000) 115 | 116 | initNonNativePoolSufficientLiquidity :: Property 117 | initNonNativePoolSufficientLiquidity = property $ do 118 | pv <- fetchPoolValidatorV1 119 | let 120 | res = initPool pv poolConf burnLqInitial (sufficientInitDepositX, initDepositY) 121 | nativePoolToLedger = toLedger pv nativePool 122 | res === Right (Predicted nativePoolToLedger nativePool, releasedLq) 123 | 124 | fromLedgerPool :: MonadIO m => m (Maybe Pool) 125 | fromLedgerPool = do 126 | pv <- fetchPoolValidatorV1 127 | let nativePoolToLedger = toLedger pv nativePool 128 | pure $ case parseFromLedger $ mkFullTxOut (TxOutRef "test" 1) nativePoolToLedger of 129 | Just (OnChain _ pool) -> Just pool 130 | _ -> Nothing 131 | 132 | toFromLedgerPoolTests = testGroup "ToFromLedgerPoolTests" 133 | [ HH.testProperty "pool_before_to_ledger_and_after_from_ledger_is_eq" poolBeforeToLedgerAndAfterFromLedgerIsEq 134 | ] 135 | 136 | poolBeforeToLedgerAndAfterFromLedgerIsEq :: Property 137 | poolBeforeToLedgerAndAfterFromLedgerIsEq = property $ do 138 | fromLedger <- fromLedgerPool 139 | Just nativePool === fromLedger 140 | 141 | depositedPP = nativePool 142 | { poolReservesX = Amount 880 143 | , poolReservesY = Amount 2200 144 | , poolLiquidity = Amount 291 145 | } 146 | 147 | checkDeposit = testGroup "CheckDeposit" 148 | [ HH.testProperty "correct_apply_deposit" correctApplyDeposit 149 | , testCase "lq_amount_is_correct" $ 150 | liquidityAmount nativePool (Amount 80, Amount 200) @=? assetAmountCoinOf poolLq 26 151 | ] 152 | 153 | correctApplyDeposit :: Property 154 | correctApplyDeposit = property $ do 155 | pv <- fetchPoolValidatorV1 156 | let 157 | deposit = applyDeposit pv nativePool (Amount 80, Amount 200) 158 | depositedPPToLedger = toLedger pv depositedPP 159 | deposit === Predicted depositedPPToLedger depositedPP 160 | 161 | redeemedPP = nativePool 162 | { poolReservesX = Amount 802 163 | , poolReservesY = Amount 2004 164 | , poolLiquidity = Amount 265 165 | } 166 | 167 | checkRedeem = testGroup "CheckRedeem" 168 | [ testCase "share_amount_is_correct" $ 169 | sharesAmount depositedPP (Amount 26) @=? (assetAmountCoinOf poolX 78, assetAmountCoinOf poolY 196) -- losts some tokens due to reward lq approximate calculation 170 | , HH.testProperty "correct_apply_redeem" $ 171 | correctApplyRedeem -- losts some tokens due to reward lq approximate calculation 172 | ] 173 | 174 | correctApplyRedeem :: Property 175 | correctApplyRedeem = property $ do 176 | pv <- fetchPoolValidatorV1 177 | let 178 | redeem = applyRedeem pv depositedPP (Amount 26) 179 | redeemPPToLedger = toLedger pv redeemedPP 180 | redeem === Predicted redeemPPToLedger redeemedPP 181 | 182 | swapXPP = nativePool 183 | { poolReservesX = Amount 820 184 | , poolReservesY = Amount 1952 185 | , poolLiquidity = Amount 265 186 | } 187 | 188 | swapYPP = nativePool 189 | { poolReservesX = Amount 770 190 | , poolReservesY = Amount 2080 191 | , poolLiquidity = Amount 265 192 | } 193 | 194 | checkSwap = testGroup "SwapCheck" 195 | [ testCase "correct_output_amount_x_base" $ 196 | outputAmount nativePool (assetAmountCoinOf baseX 20) @=? assetAmountCoinOf quoteY 48 197 | , testCase "correct_output_amount_y_base" $ 198 | outputAmount nativePool (assetAmountCoinOf baseY 80) @=? assetAmountCoinOf quoteX 30 199 | , HH.testProperty "correct_apply_swap_x_base" correctApplySwapXBase 200 | , HH.testProperty "correct_apply_swap_y_base" correctApplySwapYBase 201 | ] 202 | 203 | correctApplySwapXBase :: Property 204 | correctApplySwapXBase = property $ do 205 | pv <- fetchPoolValidatorV1 206 | let 207 | swap = applySwap pv nativePool (assetAmountCoinOf baseX 20) 208 | swapXPPToLedger = toLedger pv swapXPP 209 | swap === Predicted swapXPPToLedger swapXPP 210 | 211 | correctApplySwapYBase :: Property 212 | correctApplySwapYBase = property $ do 213 | pv <- fetchPoolValidatorV1 214 | let 215 | swap = applySwap pv nativePool (assetAmountCoinOf baseY 80) 216 | swapYPPToLedger = toLedger pv swapYPP 217 | swap === Predicted swapYPPToLedger swapYPP 218 | -------------------------------------------------------------------------------- /ergo-hs-common/CHANGELOG.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spectrum-finance/cardano-dex-sdk-haskell/39d53d78fce1cf20b78b10bff9a9fc73b747cf2a/ergo-hs-common/CHANGELOG.md -------------------------------------------------------------------------------- /ergo-hs-common/ergo-hs-common.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: ergo-hs-common 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | BangPatterns 23 | BinaryLiterals 24 | ConstraintKinds 25 | DataKinds 26 | DefaultSignatures 27 | DeriveDataTypeable 28 | DeriveFoldable 29 | DeriveFunctor 30 | DeriveGeneric 31 | DeriveTraversable 32 | DoAndIfThenElse 33 | EmptyDataDecls 34 | ExistentialQuantification 35 | FlexibleContexts 36 | FlexibleInstances 37 | FunctionalDependencies 38 | GADTs 39 | GeneralizedNewtypeDeriving 40 | InstanceSigs 41 | KindSignatures 42 | LambdaCase 43 | MultiParamTypeClasses 44 | MultiWayIf 45 | NamedFieldPuns 46 | PartialTypeSignatures 47 | PatternGuards 48 | PolyKinds 49 | RankNTypes 50 | RecordWildCards 51 | ScopedTypeVariables 52 | StandaloneDeriving 53 | TupleSections 54 | TypeFamilies 55 | TypeSynonymInstances 56 | ViewPatterns 57 | DerivingStrategies 58 | 59 | ghc-options: -Wall 60 | -Wcompat 61 | -Wincomplete-record-updates 62 | -Wincomplete-uni-patterns 63 | -Wpartial-fields 64 | -Wredundant-constraints 65 | -Wunused-packages 66 | -Widentities 67 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 68 | 69 | library 70 | import: base, project-config 71 | 72 | hs-source-dirs: src 73 | 74 | exposed-modules: 75 | Common.Throw.Combinators 76 | Common.Data.List.Combinators 77 | 78 | build-depends: rio, plutus-ledger-api, plutus-tx, containers -------------------------------------------------------------------------------- /ergo-hs-common/src/Common/Data/List/Combinators.hs: -------------------------------------------------------------------------------- 1 | module Common.Data.List.Combinators 2 | ( indexOf 3 | ) where 4 | 5 | indexOf :: (Eq a, Integral s) => a -> [a] -> s 6 | indexOf a as = indexOf' a as 0 7 | where 8 | indexOf' :: (Eq a, Integral s) => a -> [a] -> s -> s 9 | indexOf' _ [] _ = -1 10 | indexOf' a' (x:xs) s 11 | | a' == x = s 12 | | otherwise = indexOf' a' xs (s + 1) 13 | -------------------------------------------------------------------------------- /ergo-hs-common/src/Common/Throw/Combinators.hs: -------------------------------------------------------------------------------- 1 | module Common.Throw.Combinators where 2 | 3 | import RIO 4 | 5 | throwEither :: (MonadThrow f, Exception e) => Either e r -> f r 6 | throwEither (Left err) = throwM err 7 | throwEither (Right value) = pure value 8 | 9 | throwMaybe :: (MonadThrow f, Exception e) => e -> Maybe a -> f a 10 | throwMaybe _ (Just value) = pure value 11 | throwMaybe err _ = throwM err -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "./ergo-hs-common/src" 4 | component: "ergo-hs-common:lib:ergo-hs-common" 5 | - path: "./cardano-tx/src" 6 | component: "cardano-tx:lib:cardano-tx" 7 | - path: "./dex-core/src" 8 | component: "dex-core:lib:dex-core" 9 | - path: "./dex-core/test" 10 | component: "dex-core:test:dex-core-tests" 11 | - path: "./quickblue/src" 12 | component: "quickblue:lib:quickblue" 13 | - path: "./network-api/src" 14 | component: "network-api:lib:network-api" 15 | - path: "./wallet-api/src" 16 | component: "wallet-api:lib:wallet-api" 17 | - path: "./submit-api/src" 18 | component: "submit-api:lib:submit-api" 19 | - path: "./submit-api/test" 20 | component: "submit-api:test:submit-api-tests" 21 | - path: "./datum-keeper-client/src" 22 | component: "datum-keeper-client:lib:datum-keeper-client" 23 | - path: "./spectrum/src" 24 | component: "spectrum:lib:spectrum" 25 | - path: "./algebra-core/src" 26 | component: "algebra-core:lib:algebra-core" 27 | - path: "./spectrum-prelude/src" 28 | component: "spectrum-prelude:lib:spectrum-prelude" 29 | - path: "./ledger-sync/src" 30 | component: "ledger-sync:lib:ledger-sync" 31 | 32 | -------------------------------------------------------------------------------- /ledger-sync/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /ledger-sync/ledger-sync.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: ledger-sync 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: ErgoLabs 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | BangPatterns 23 | BinaryLiterals 24 | ConstraintKinds 25 | DataKinds 26 | DefaultSignatures 27 | DeriveDataTypeable 28 | DeriveFoldable 29 | DeriveFunctor 30 | DeriveGeneric 31 | DeriveTraversable 32 | DerivingStrategies 33 | DoAndIfThenElse 34 | EmptyDataDecls 35 | ExistentialQuantification 36 | FlexibleContexts 37 | FlexibleInstances 38 | FunctionalDependencies 39 | UndecidableInstances 40 | GADTs 41 | GeneralizedNewtypeDeriving 42 | InstanceSigs 43 | KindSignatures 44 | LambdaCase 45 | MultiParamTypeClasses 46 | MultiWayIf 47 | NamedFieldPuns 48 | PartialTypeSignatures 49 | PatternGuards 50 | PolyKinds 51 | RankNTypes 52 | RecordWildCards 53 | ScopedTypeVariables 54 | StandaloneDeriving 55 | TupleSections 56 | TypeApplications 57 | TypeFamilies 58 | TypeSynonymInstances 59 | ViewPatterns 60 | 61 | ghc-options: -O2 62 | -Wall 63 | -Wcompat 64 | -Wincomplete-record-updates 65 | -Wincomplete-uni-patterns 66 | -Wpartial-fields 67 | -Wredundant-constraints 68 | -Wunused-packages 69 | -Widentities 70 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 71 | 72 | library 73 | import: base, project-config 74 | 75 | hs-source-dirs: src 76 | 77 | exposed-modules: Spectrum.Config 78 | Spectrum.Topic 79 | Spectrum.LedgerSync 80 | Spectrum.LedgerSync.Config 81 | Spectrum.LedgerSync.Exception 82 | Spectrum.EventSource.Data.Tx 83 | Spectrum.EventSource.Data.TxContext 84 | Spectrum.EventSource.Data.TxEvent 85 | Spectrum.EventSource.Persistence.Data.BlockLinks 86 | Spectrum.EventSource.Persistence.Config 87 | Spectrum.EventSource.Persistence.LedgerHistory 88 | Spectrum.EventSource.Stream 89 | Spectrum.EventSource.Types 90 | Spectrum.LedgerSync.Data.LedgerUpdate 91 | Spectrum.LedgerSync.Data.MempoolUpdate 92 | Spectrum.LedgerSync.Protocol.Client 93 | Spectrum.LedgerSync.Protocol.ChainSync 94 | Spectrum.LedgerSync.Protocol.MempoolSync 95 | Spectrum.LedgerSync.Protocol.Data.ChainSync 96 | Spectrum.LedgerSync.Protocol.Data.MempoolSync 97 | Cardano.Network.Protocol.NodeToClient.Trace 98 | 99 | build-depends: bytestring 100 | , aeson 101 | , lens-aeson 102 | , rio 103 | , mmorph 104 | , generic-lens 105 | , containers 106 | , stm 107 | , text 108 | , ouroboros-consensus-protocol 109 | , dex-core 110 | , hashable 111 | , utf8-string 112 | , time 113 | , dhall 114 | , yaml 115 | , transformers 116 | , unliftio-core 117 | , io-classes 118 | , resourcet 119 | , exceptions 120 | , profunctors 121 | , spectrum-prelude 122 | , base16 123 | , base58-bytestring 124 | , base64 125 | , bech32 126 | , cborg 127 | , bytestring 128 | , contra-tracer 129 | , cardano-api 130 | , cardano-binary 131 | , cardano-crypto 132 | , cardano-crypto-class 133 | , cardano-crypto-wrapper 134 | , cardano-ledger-alonzo 135 | , cardano-ledger-byron 136 | , cardano-ledger-core 137 | , cardano-ledger-shelley 138 | , cardano-ledger-shelley-ma 139 | , cardano-protocol-tpraos 140 | , cardano-slotting 141 | , cardano-ledger-babbage 142 | , cardano-tx 143 | , plutus-ledger-api 144 | , plutus-ledger 145 | , plutus-tx 146 | , ouroboros-consensus 147 | , ouroboros-consensus-byron 148 | , ouroboros-consensus-cardano 149 | , ouroboros-consensus-shelley 150 | , ouroboros-consensus-protocol 151 | , ouroboros-network 152 | , ouroboros-network-framework 153 | , typed-protocols 154 | , typed-protocols-cborg 155 | , network-mux 156 | , iohk-monitoring 157 | , hlog 158 | , spectrum 159 | , rocksdb-haskell 160 | , streamly 161 | , monad-control 162 | , unagi-chan 163 | , dependent-sum 164 | , dependent-sum-template >= 0.1 && < 0.2 165 | , dependent-map >= 0.3 && < 0.5 166 | , aeson-gadt-th 167 | -------------------------------------------------------------------------------- /ledger-sync/src/Cardano/Network/Protocol/NodeToClient/Trace.hs: -------------------------------------------------------------------------------- 1 | module Cardano.Network.Protocol.NodeToClient.Trace where 2 | 3 | import Cardano.BM.Data.Severity 4 | ( Severity (..) ) 5 | import Cardano.BM.Data.Tracer 6 | ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) 7 | import Codec.CBOR.Term 8 | ( Term ) 9 | import Data.Aeson 10 | ( (.=) ) 11 | import GHC.Generics 12 | ( Generic ) 13 | import Network.Mux 14 | ( WithMuxBearer (..) ) 15 | import Network.TypedProtocol.Codec 16 | ( AnyMessageAndAgency (..) ) 17 | import Ouroboros.Network.Driver.Simple 18 | ( TraceSendRecv (..) ) 19 | import Ouroboros.Network.NodeToClient 20 | ( ConnectionId (..), LocalAddress, NodeToClientVersion ) 21 | import Ouroboros.Network.Protocol.Handshake.Type 22 | ( Handshake, Message (..), RefuseReason (..) ) 23 | 24 | import qualified Data.Aeson as Json 25 | import qualified Data.Aeson.Types as Json 26 | import qualified Data.Map.Strict as Map 27 | 28 | type HandshakeTrace = TraceSendRecv (Handshake NodeToClientVersion Term) 29 | 30 | data TraceClient 31 | = TrHandshake (WithMuxBearer (ConnectionId LocalAddress) HandshakeTrace) 32 | deriving (Generic, Show) 33 | 34 | encodeTraceClient :: TraceClient -> Json.Value 35 | encodeTraceClient= \case 36 | TrHandshake tr -> 37 | Json.object (("tag" .= Json.String "Handshake") : encodeTraceSendRecvHandshake tr) 38 | where 39 | encodeTraceSendRecvHandshake = \case 40 | WithMuxBearer _peerId (TraceSendMsg (AnyMessageAndAgency agency msg)) -> 41 | [ "event" .= ("send" :: String) 42 | , "agency" .= show agency 43 | ] ++ encodeMsg msg 44 | WithMuxBearer _peerId (TraceRecvMsg (AnyMessageAndAgency agency msg)) -> 45 | [ "event" .= ("receive" :: String) 46 | , "agency" .= show agency 47 | ] ++ encodeMsg msg 48 | where 49 | encodeMsg 50 | :: Message (Handshake NodeToClientVersion Term) from to 51 | -> [Json.Pair] 52 | encodeMsg = \case 53 | MsgProposeVersions versions -> 54 | [ "tag" .= ("ProposeVersions" :: String) 55 | , "versions" .= (show <$> Map.keys versions) 56 | ] 57 | MsgReplyVersions versions -> 58 | [ "tag" .= ("ReplyVersions" :: String) 59 | , "versions" .= (show <$> Map.keys versions) 60 | ] 61 | MsgAcceptVersion v _ -> 62 | [ "tag" .= ("AcceptVersion" :: String) 63 | , "version" .= show (show v) 64 | ] 65 | MsgRefuse reason -> 66 | [ "tag" .= ("RefuseVersions" :: String) 67 | , "reason" .= encodeRefuseReason reason 68 | ] 69 | 70 | encodeRefuseReason 71 | :: RefuseReason vNumber 72 | -> Json.Value 73 | encodeRefuseReason = \case 74 | VersionMismatch{} -> Json.String "VersionMismatchOrUnknown" 75 | HandshakeDecodeError{} -> Json.String "HandshakeDecodeError" 76 | Refused{} -> Json.String "ServerRejected" 77 | 78 | instance HasPrivacyAnnotation TraceClient 79 | instance HasSeverityAnnotation TraceClient where 80 | getSeverityAnnotation = \case 81 | TrHandshake{} -> Info 82 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/Config.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.Config where 2 | 3 | import GHC.Generics 4 | ( Generic ) 5 | import Dhall 6 | ( FromDhall, input, auto ) 7 | 8 | import Spectrum.EventSource.Types 9 | ( ConcretePoint ) 10 | 11 | data EventSourceConfig = EventSourceConfig 12 | { startAt :: !ConcretePoint 13 | } deriving (Generic, FromDhall) -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/EventSource/Data/Tx.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# OPTIONS_GHC -ddump-splices #-} 11 | 12 | module Spectrum.EventSource.Data.Tx 13 | ( MinimalUnconfirmedTx(..) 14 | , MinimalConfirmedTx(..) 15 | , MinimalTx(..) 16 | , fromBabbageLedgerTx 17 | , fromMempoolBabbageLedgerTx 18 | ) where 19 | 20 | import RIO 21 | ( (<&>), Generic ) 22 | import Data.Foldable 23 | ( Foldable(toList) ) 24 | 25 | import Data.Aeson 26 | import Data.Aeson.GADT.TH 27 | import Data.Dependent.Map (DMap) 28 | import Data.Dependent.Sum (DSum) 29 | import Data.Functor.Identity 30 | import Data.GADT.Compare 31 | import Data.GADT.Show.TH 32 | import Data.Some (Some(..)) 33 | 34 | import qualified Ledger as P 35 | import qualified Data.Set as Set 36 | 37 | import qualified Cardano.Ledger.Babbage.Tx as Al 38 | import qualified Cardano.Crypto.Hash.Class as CC 39 | import qualified Cardano.Ledger.SafeHash as Ledger 40 | import qualified Cardano.Ledger.TxIn as Ledger 41 | 42 | import qualified PlutusTx.Prelude as PlutusTx 43 | 44 | import CardanoTx.Models 45 | ( FullTxOut (FullTxOut), TxOutDatum (EmptyDatum, KnownDatumHash, KnownDatum) ) 46 | import Cardano.Api.Shelley 47 | ( fromShelleyTxIn, fromShelleyTxOut, ShelleyBasedEra (ShelleyBasedEraBabbage), SlotNo ) 48 | import Spectrum.EventSource.Data.TxContext 49 | ( TxCtx(MempoolCtx, LedgerCtx) ) 50 | import Ouroboros.Consensus.Cardano.Block 51 | ( EraCrypto, StandardCrypto, BabbageEra) 52 | import Ouroboros.Consensus.Shelley.Ledger 53 | ( ShelleyHash (unShelleyHash) ) 54 | import Cardano.Ledger.Crypto 55 | ( Crypto ) 56 | import Cardano.Ledger.Serialization 57 | ( Sized(sizedValue) ) 58 | 59 | import qualified Ledger.Tx.CardanoAPI as Interop 60 | import qualified CardanoTx.Interop as Interop 61 | import qualified Plutus.V2.Ledger.Tx as PV2 62 | import Cardano.Api (ToJSON, FromJSON) 63 | import GHC.Generics (Generic1) 64 | 65 | -- | A minimal sufficient representation of an unconfirmed transaction 66 | data MinimalUnconfirmedTx = MinimalUnconfirmedTx 67 | { txId :: P.TxId 68 | , txInputs :: Set.Set P.TxIn 69 | , txOutputs :: [FullTxOut] 70 | , slotNo :: SlotNo 71 | } deriving (Show, Eq, Generic, FromJSON, ToJSON) 72 | 73 | -- | A minimal sufficient representation of a confirmed transaction 74 | data MinimalConfirmedTx = MinimalConfirmedTx 75 | { blockId :: P.BlockId 76 | , txId :: P.TxId 77 | , txInputs :: Set.Set P.TxIn 78 | , txOutputs :: [FullTxOut] 79 | , slotNo :: SlotNo 80 | } deriving (Show, Eq, Generic, FromJSON, ToJSON) 81 | 82 | data MinimalTx ctx where 83 | MinimalMempoolTx :: MinimalUnconfirmedTx -> MinimalTx 'MempoolCtx 84 | MinimalLedgerTx :: MinimalConfirmedTx -> MinimalTx 'LedgerCtx 85 | 86 | deriving instance Eq (MinimalTx ctx) 87 | deriving instance Show (MinimalTx ctx) 88 | 89 | deriveJSONGADT ''MinimalTx 90 | 91 | fromBabbageLedgerTx 92 | :: (Crypto crypto, crypto ~ StandardCrypto) 93 | => ShelleyHash (EraCrypto (BabbageEra crypto)) 94 | -> SlotNo 95 | -> Al.ValidatedTx (BabbageEra crypto) -> MinimalTx 'LedgerCtx 96 | fromBabbageLedgerTx blockHash slotNo vtx = 97 | let 98 | body = Al.body vtx 99 | blockId 100 | = P.BlockId 101 | . CC.hashToBytes 102 | $ unShelleyHash blockHash 103 | txId 104 | = P.TxId 105 | . PlutusTx.toBuiltin 106 | . CC.hashToBytes 107 | . Ledger.extractHash 108 | . Ledger._unTxId 109 | . Ledger.txid 110 | $ body 111 | fromCardanoTxIn tin = P.TxIn (Interop.fromCardanoTxIn (fromShelleyTxIn tin)) Nothing 112 | fromCardanoTxOut ix tout = 113 | Interop.fromCardanoTxOutV2 (fromShelleyTxOut ShelleyBasedEraBabbage (sizedValue tout)) <&> (\PV2.TxOut{..} -> 114 | FullTxOut 115 | (P.TxOutRef txId ix) 116 | txOutAddress 117 | txOutValue 118 | (parseDatum txOutDatum) 119 | txOutReferenceScript) 120 | parseDatum datum = case datum of 121 | PV2.NoOutputDatum -> EmptyDatum 122 | PV2.OutputDatumHash dh -> KnownDatumHash dh 123 | PV2.OutputDatum d -> KnownDatum d 124 | in MinimalLedgerTx $ MinimalConfirmedTx 125 | { blockId = blockId 126 | , txId = txId 127 | , txInputs = Set.fromList $ Set.toList (Al.inputs body) <&> fromCardanoTxIn 128 | , txOutputs = zip [0..] (toList $ Al.outputs body) 129 | <&> uncurry fromCardanoTxOut 130 | >>= either mempty pure 131 | , slotNo = slotNo 132 | } 133 | 134 | fromMempoolBabbageLedgerTx 135 | :: (Crypto crypto, crypto ~ StandardCrypto) 136 | => Al.ValidatedTx (BabbageEra crypto) 137 | -> SlotNo 138 | -> MinimalTx 'MempoolCtx 139 | fromMempoolBabbageLedgerTx vtx slotNo = 140 | let 141 | body = Al.body vtx 142 | txId 143 | = P.TxId 144 | . PlutusTx.toBuiltin 145 | . CC.hashToBytes 146 | . Ledger.extractHash 147 | . Ledger._unTxId 148 | . Ledger.txid 149 | $ body 150 | fromCardanoTxIn tin = P.TxIn (Interop.fromCardanoTxIn (fromShelleyTxIn tin)) Nothing 151 | fromCardanoTxOut ix tout = 152 | Interop.fromCardanoTxOutV2 (fromShelleyTxOut ShelleyBasedEraBabbage (sizedValue tout)) <&> (\PV2.TxOut{..} -> 153 | FullTxOut 154 | (P.TxOutRef txId ix) 155 | txOutAddress 156 | txOutValue 157 | (parseDatum txOutDatum) 158 | txOutReferenceScript) 159 | parseDatum datum = case datum of 160 | PV2.NoOutputDatum -> EmptyDatum 161 | PV2.OutputDatumHash dh -> KnownDatumHash dh 162 | PV2.OutputDatum d -> KnownDatum d 163 | in MinimalMempoolTx $ MinimalUnconfirmedTx 164 | { txId = txId 165 | , txInputs = Set.fromList $ Set.toList (Al.inputs body) <&> fromCardanoTxIn 166 | , txOutputs = zip [0..] (toList $ Al.outputs body) 167 | <&> uncurry fromCardanoTxOut 168 | >>= either mempty pure 169 | , slotNo = slotNo 170 | } 171 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/EventSource/Data/TxContext.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.EventSource.Data.TxContext 2 | ( TxCtx(..) 3 | ) where 4 | 5 | data TxCtx = LedgerCtx | MempoolCtx 6 | deriving (Eq, Show) 7 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/EventSource/Data/TxEvent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# OPTIONS_GHC -ddump-splices #-} 9 | 10 | module Spectrum.EventSource.Data.TxEvent 11 | ( TxEvent(..) 12 | ) where 13 | 14 | import Data.Aeson 15 | import Data.Aeson.GADT.TH 16 | 17 | import Spectrum.EventSource.Data.Tx 18 | ( MinimalTx ) 19 | import Spectrum.EventSource.Data.TxContext 20 | ( TxCtx(MempoolCtx, LedgerCtx) ) 21 | import qualified Ledger as P 22 | import Cardano.Api (ToJSON) 23 | 24 | data TxEvent ctx where 25 | PendingTx :: MinimalTx 'MempoolCtx -> TxEvent 'MempoolCtx 26 | AppliedTx :: MinimalTx 'LedgerCtx -> TxEvent 'LedgerCtx 27 | UnappliedTx :: P.TxId -> TxEvent 'LedgerCtx 28 | 29 | deriving instance Eq (TxEvent ctx) 30 | deriving instance Show (TxEvent ctx) 31 | 32 | deriveJSONGADT ''TxEvent -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/EventSource/Persistence/Config.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.EventSource.Persistence.Config 2 | ( LedgerStoreConfig(..) 3 | ) where 4 | 5 | import GHC.Generics 6 | ( Generic ) 7 | import Dhall 8 | ( FromDhall ) 9 | 10 | data LedgerStoreConfig = LedgerStoreConfig 11 | { storePath :: !FilePath 12 | , createIfMissing :: !Bool 13 | } 14 | deriving (Generic, FromDhall) 15 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/EventSource/Persistence/Data/BlockLinks.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.EventSource.Persistence.Data.BlockLinks where 2 | 3 | import GHC.Generics 4 | ( Generic ) 5 | 6 | import Data.Aeson 7 | ( ToJSON, FromJSON ) 8 | 9 | import Ledger 10 | ( TxId ) 11 | import Spectrum.EventSource.Types 12 | ( ConcretePoint ) 13 | 14 | data BlockLinks = BlockLinks 15 | { prevPoint :: ConcretePoint 16 | , txIds :: [TxId] 17 | } deriving (Eq, Show, Generic, ToJSON, FromJSON) 18 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/EventSource/Persistence/LedgerHistory.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.EventSource.Persistence.LedgerHistory 2 | ( LedgerHistory(..) 3 | , mkLedgerHistory 4 | , mkRuntimeLedgerHistory 5 | ) where 6 | 7 | import RIO 8 | ( ByteString 9 | , ($>) 10 | , newIORef 11 | , readIORef 12 | , writeIORef 13 | , (<&>) 14 | , isJust 15 | ) 16 | 17 | import qualified Data.Map as Map 18 | 19 | import Control.Monad.IO.Class 20 | ( MonadIO ) 21 | import Control.Monad.Trans.Resource 22 | ( MonadResource ) 23 | 24 | import System.Logging.Hlog 25 | ( Logging (..), MakeLogging (..) ) 26 | 27 | import qualified Database.RocksDB as Rocks 28 | 29 | import Spectrum.EventSource.Types 30 | ( ConcretePoint ) 31 | import Spectrum.EventSource.Persistence.Data.BlockLinks 32 | ( BlockLinks ) 33 | import Spectrum.EventSource.Persistence.Config 34 | ( LedgerStoreConfig (..) ) 35 | import Spectrum.Common.Persistence.Serialization (serialize, deserializeM) 36 | import Control.Monad.Catch (MonadThrow) 37 | 38 | data LedgerHistory m = LedgerHistory 39 | { setTip :: ConcretePoint -> m () 40 | , getTip :: m (Maybe ConcretePoint) 41 | , putBlock :: ConcretePoint -> BlockLinks -> m () 42 | , getBlock :: ConcretePoint -> m (Maybe BlockLinks) 43 | , pointExists :: ConcretePoint -> m Bool 44 | , dropBlock :: ConcretePoint -> m Bool 45 | } 46 | 47 | mkLedgerHistory 48 | :: (MonadIO f, MonadResource f, MonadIO m, MonadThrow m) 49 | => MakeLogging f m 50 | -> LedgerStoreConfig 51 | -> f (LedgerHistory m) 52 | mkLedgerHistory MakeLogging{..} LedgerStoreConfig{..} = do 53 | logging <- forComponent "LedgerHistory" 54 | (_, db) <- Rocks.openBracket storePath 55 | Rocks.defaultOptions 56 | { Rocks.createIfMissing = createIfMissing 57 | } 58 | let 59 | readopts = Rocks.defaultReadOptions 60 | writeopts = Rocks.defaultWriteOptions 61 | pure $ attachLogging logging LedgerHistory 62 | { setTip = Rocks.put db writeopts lastPointKey . serialize 63 | , getTip = Rocks.get db readopts lastPointKey >>= mapM deserializeM 64 | , putBlock = \point blk -> Rocks.put db writeopts (serialize point) (serialize blk) 65 | , getBlock = \point -> Rocks.get db readopts (serialize point) >>= mapM deserializeM 66 | , pointExists = \point -> Rocks.get db readopts (serialize point) <&> isJust 67 | , dropBlock = \point -> do 68 | let pkey = serialize point 69 | exists <- Rocks.get db readopts pkey <&> isJust 70 | if exists 71 | then Rocks.delete db writeopts pkey $> True 72 | else pure False 73 | } 74 | 75 | -- | Runtime-only storage primarily for tests. 76 | mkRuntimeLedgerHistory :: (MonadIO m, MonadThrow m) => MakeLogging m m -> m (LedgerHistory m) 77 | mkRuntimeLedgerHistory MakeLogging{..} = do 78 | store <- newIORef mempty 79 | logging <- forComponent "LedgerHistory" 80 | pure $ attachLogging logging LedgerHistory 81 | { setTip = \p -> do 82 | s <- readIORef store 83 | writeIORef store $ Map.insert lastPointKey (serialize p) s 84 | , getTip = do 85 | s <- readIORef store 86 | mapM deserializeM $ Map.lookup lastPointKey s 87 | , putBlock = \point blk -> do 88 | s <- readIORef store 89 | writeIORef store $ Map.insert (serialize point) (serialize blk) s 90 | , getBlock = \point -> do 91 | s <- readIORef store 92 | mapM deserializeM $ Map.lookup (serialize point) s 93 | , pointExists = \point -> do 94 | s <- readIORef store 95 | pure $ Map.member (serialize point) s 96 | , dropBlock = \point -> do 97 | s <- readIORef store 98 | let 99 | pkey = serialize point 100 | exists = Map.member pkey s 101 | if exists 102 | then writeIORef store (Map.delete pkey s) $> True 103 | else pure False 104 | } 105 | 106 | attachLogging :: Monad m => Logging m -> LedgerHistory m -> LedgerHistory m 107 | attachLogging Logging{..} LedgerHistory{..} = 108 | LedgerHistory 109 | { setTip = \point -> do 110 | infoM $ "setTip " <> show point 111 | r <- setTip point 112 | infoM $ "setTip " <> show point <> " -> " <> show r 113 | pure r 114 | , getTip = do 115 | infoM @String "getTip" 116 | r <- getTip 117 | infoM $ "getTip -> " <> show r 118 | pure r 119 | , putBlock = \point blk -> do 120 | infoM $ "putBlock " <> show point 121 | r <- putBlock point blk 122 | infoM $ "putBlock " <> show point <> " -> " <> show r 123 | pure r 124 | , getBlock = \point -> do 125 | infoM $ "getBlock " <> show point 126 | r <- getBlock point 127 | infoM $ "getBlock " <> show point <> " -> " <> show r 128 | pure r 129 | , pointExists = \point -> do 130 | infoM $ "pointExists " <> show point 131 | r <- pointExists point 132 | infoM $ "pointExists " <> show point <> " -> " <> show r 133 | pure r 134 | , dropBlock = \point -> do 135 | infoM $ "dropBlock " <> show point 136 | r <- dropBlock point 137 | infoM $ "dropBlock " <> show point <> " -> " <> show r 138 | pure r 139 | } 140 | 141 | lastPointKey :: ByteString 142 | lastPointKey = "lastPoint" 143 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/EventSource/Stream.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.EventSource.Stream 2 | ( EventSource(..) 3 | , mkLedgerEventSource 4 | , mkMempoolTxEventSource 5 | ) where 6 | 7 | import RIO 8 | ( (&), MonadReader, (<&>), fromMaybe, ($>) ) 9 | 10 | import Data.ByteString.Short 11 | ( toShort ) 12 | 13 | import Control.Monad.Trans.Control 14 | ( MonadBaseControl ) 15 | import Control.Monad.IO.Class 16 | ( MonadIO ) 17 | import Control.Monad.Catch 18 | ( MonadThrow ) 19 | import Control.Monad 20 | ( join ) 21 | import Control.Monad.Trans.Resource 22 | ( MonadResource ) 23 | 24 | import Streamly.Prelude as S 25 | 26 | import System.Logging.Hlog 27 | ( MakeLogging(..), Logging(..) ) 28 | 29 | import qualified Ouroboros.Consensus.Protocol.Praos.Header as Praos 30 | import Ouroboros.Consensus.Shelley.Ledger 31 | ( ShelleyBlock(ShelleyBlock), ShelleyHash (unShelleyHash), GenTx (..) ) 32 | import Ouroboros.Consensus.HardFork.Combinator 33 | ( OneEraHash(OneEraHash) ) 34 | import Ouroboros.Consensus.Cardano.Block 35 | ( HardForkBlock(BlockBabbage), GenTx (GenTxBabbage) ) 36 | import Ouroboros.Consensus.Block 37 | ( Point ) 38 | 39 | import Cardano.Ledger.Alonzo.TxSeq 40 | ( TxSeq(txSeqTxns) ) 41 | import qualified Cardano.Ledger.Block as Ledger 42 | import qualified Cardano.Crypto.Hash as CC 43 | 44 | import Spectrum.LedgerSync.Protocol.Client 45 | ( Block ) 46 | import Spectrum.EventSource.Data.Tx 47 | ( fromBabbageLedgerTx, fromMempoolBabbageLedgerTx ) 48 | import Spectrum.LedgerSync 49 | ( LedgerSync(..) ) 50 | import Spectrum.Prelude.Context 51 | ( HasType, askContext ) 52 | import Spectrum.Config 53 | ( EventSourceConfig (EventSourceConfig, startAt) ) 54 | import Spectrum.EventSource.Types 55 | ( ConcretePoint (ConcretePoint) 56 | , toPoint 57 | , fromPoint 58 | , ConcretePoint (slot) 59 | , ConcreteHash (ConcreteHash) 60 | ) 61 | import Spectrum.EventSource.Persistence.LedgerHistory 62 | ( LedgerHistory (..), mkLedgerHistory ) 63 | import Spectrum.EventSource.Data.TxEvent 64 | ( TxEvent(AppliedTx, UnappliedTx, PendingTx) ) 65 | import Spectrum.EventSource.Data.TxContext 66 | ( TxCtx(LedgerCtx, MempoolCtx) ) 67 | import Spectrum.LedgerSync.Data.LedgerUpdate 68 | ( LedgerUpdate(RollForward, RollBackward) ) 69 | import Spectrum.EventSource.Persistence.Data.BlockLinks 70 | ( BlockLinks(BlockLinks, txIds, prevPoint) ) 71 | import Spectrum.LedgerSync.Data.MempoolUpdate 72 | ( MempoolUpdate(..) ) 73 | import Spectrum.EventSource.Persistence.Config 74 | ( LedgerStoreConfig ) 75 | import Spectrum.Prelude.HigherKind 76 | ( LiftK (liftK) ) 77 | 78 | newtype EventSource s m ctx = EventSource 79 | { upstream :: s m (TxEvent ctx) 80 | } 81 | 82 | mkLedgerEventSource 83 | :: forall f m s env. 84 | ( Monad f 85 | , MonadResource f 86 | , LiftK m f 87 | , IsStream s 88 | , Monad (s m) 89 | , MonadAsync m 90 | , MonadReader env f 91 | , HasType (MakeLogging f m) env 92 | , HasType EventSourceConfig env 93 | , HasType LedgerStoreConfig env 94 | ) 95 | => LedgerSync m 96 | -> f (EventSource s m 'LedgerCtx) 97 | mkLedgerEventSource lsync = do 98 | mklog@MakeLogging{..} <- askContext 99 | EventSourceConfig{startAt} <- askContext 100 | lhcong <- askContext 101 | 102 | logging <- forComponent "LedgerEventSource" 103 | persistence <- mkLedgerHistory mklog lhcong 104 | 105 | liftK $ seekToBeginning logging persistence lsync startAt 106 | pure $ EventSource 107 | { upstream = upstream' logging persistence lsync 108 | } 109 | 110 | mkMempoolTxEventSource 111 | :: forall f m s env. 112 | ( Monad f 113 | , MonadResource f 114 | , IsStream s 115 | , Monad (s m) 116 | , MonadAsync m 117 | , MonadReader env f 118 | , HasType (MakeLogging f m) env 119 | ) 120 | => LedgerSync m 121 | -> f (EventSource s m 'MempoolCtx) 122 | mkMempoolTxEventSource lsync = do 123 | MakeLogging{..} <- askContext 124 | logging <- forComponent "MempoolEventSource" 125 | 126 | pure $ EventSource 127 | { upstream = upstreamMempoolTxs' logging lsync 128 | } 129 | 130 | upstream' 131 | :: forall s m. (IsStream s, Monad (s m), MonadAsync m) 132 | => Logging m 133 | -> LedgerHistory m 134 | -> LedgerSync m 135 | -> s m (TxEvent 'LedgerCtx) 136 | upstream' logging@Logging{..} persistence LedgerSync{..} 137 | = S.repeatM pull >>= processUpdate logging persistence 138 | & S.trace (debugM . show) 139 | 140 | upstreamMempoolTxs' 141 | :: forall s m. (IsStream s, Monad (s m), MonadAsync m) 142 | => Logging m 143 | -> LedgerSync m 144 | -> s m (TxEvent 'MempoolCtx) 145 | upstreamMempoolTxs' logging@Logging{..} LedgerSync{..} 146 | = S.repeatM pullTx >>= processMempoolUpdate logging 147 | & S.trace (debugM . show) 148 | 149 | processUpdate 150 | :: forall s m. 151 | ( IsStream s 152 | , Monad (s m) 153 | , MonadIO m 154 | , MonadBaseControl IO m 155 | , MonadThrow m 156 | ) 157 | => Logging m 158 | -> LedgerHistory m 159 | -> LedgerUpdate Block 160 | -> s m (TxEvent 'LedgerCtx) 161 | processUpdate 162 | _ 163 | LedgerHistory{..} 164 | (RollForward (BlockBabbage (ShelleyBlock (Ledger.Block (Praos.Header hBody _) txs) hHash))) = 165 | let 166 | txs' = txSeqTxns txs 167 | slotNo = Praos.hbSlotNo hBody 168 | point = ConcretePoint slotNo (ConcreteHash ch) 169 | where ch = OneEraHash . toShort . CC.hashToBytes . unShelleyHash $ hHash 170 | in S.before (setTip point) 171 | $ S.fromFoldable txs' & S.map (AppliedTx . fromBabbageLedgerTx hHash slotNo) 172 | processUpdate logging lh (RollBackward point) = streamUnappliedTxs logging lh point 173 | processUpdate Logging{..} _ upd = S.before (errorM $ "Cannot process update " <> show upd) mempty 174 | 175 | processMempoolUpdate 176 | :: forall s m. 177 | ( IsStream s 178 | , MonadIO m 179 | , MonadBaseControl IO m 180 | , MonadThrow m 181 | ) 182 | => Logging m 183 | -> MempoolUpdate Block 184 | -> s m (TxEvent 'MempoolCtx) 185 | processMempoolUpdate _ (NewTx (GenTxBabbage (ShelleyTx _ x)) slot) = S.fromList [PendingTx $ fromMempoolBabbageLedgerTx x slot] 186 | processMempoolUpdate Logging{..} _ = S.before (errorM @String "Cannot process mempool update") mempty 187 | 188 | streamUnappliedTxs 189 | :: forall s m. 190 | ( IsStream s 191 | , Monad (s m) 192 | , MonadIO m 193 | , MonadBaseControl IO m 194 | , MonadThrow m 195 | ) 196 | => Logging m 197 | -> LedgerHistory m 198 | -> Point Block 199 | -> s m (TxEvent 'LedgerCtx) 200 | streamUnappliedTxs Logging{..} LedgerHistory{..} point = join $ S.fromEffect $ do 201 | knownPoint <- pointExists $ fromPoint point 202 | let 203 | rollbackOne :: ConcretePoint -> s m (TxEvent 'LedgerCtx) 204 | rollbackOne pt = do 205 | block <- S.fromEffect $ getBlock pt 206 | case block of 207 | Just BlockLinks{..} -> do 208 | S.fromEffect $ dropBlock pt >> setTip prevPoint 209 | let emitTxs = S.fromFoldable (Prelude.reverse txIds <&> UnappliedTx) -- unapply txs in reverse order 210 | if toPoint prevPoint == point 211 | then emitTxs 212 | else emitTxs <> rollbackOne prevPoint 213 | Nothing -> mempty 214 | tipM <- getTip 215 | case tipM of 216 | Just tip -> 217 | if knownPoint 218 | then infoM ("Rolling back to point " <> show point) $> rollbackOne tip 219 | else errorM ("An attempt to roll back to an unknown point " <> show point) $> mempty 220 | Nothing -> pure mempty 221 | 222 | seekToBeginning 223 | :: Monad m 224 | => Logging m 225 | -> LedgerHistory m 226 | -> LedgerSync m 227 | -> ConcretePoint 228 | -> m () 229 | seekToBeginning Logging{..} LedgerHistory{..} LedgerSync{..} pointLowConf = do 230 | lastCheckpoint <- getTip 231 | let 232 | confSlot = slot pointLowConf 233 | pointLow = fromMaybe pointLowConf 234 | $ lastCheckpoint <&> (\p -> if confSlot > slot p then pointLowConf else p) 235 | infoM $ "Seeking to point " <> show pointLow 236 | seekTo $ toPoint pointLow 237 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/EventSource/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | 3 | module Spectrum.EventSource.Types 4 | ( ConcretePoint(..) 5 | , ConcreteHash(..) 6 | , toPoint 7 | , fromPoint 8 | ) where 9 | 10 | import GHC.Generics ( Generic ) 11 | 12 | import qualified Data.Text as T 13 | 14 | import Data.ByteString.Short 15 | ( toShort, fromShort ) 16 | import Data.ByteString.Base16 17 | ( encodeBase16 ) 18 | import Data.Aeson 19 | ( ToJSON(..), FromJSON(..) ) 20 | import Data.Aeson.Types 21 | ( Value(String) ) 22 | 23 | 24 | import qualified Dhall as D 25 | import Dhall 26 | ( FromDhall ) 27 | import Dhall.Core 28 | ( Expr(..), Chunks(..) ) 29 | 30 | import Ouroboros.Consensus.Block 31 | ( SlotNo(SlotNo), Point (BlockPoint) ) 32 | import Ouroboros.Network.Block 33 | ( HeaderHash, atSlot, withHash ) 34 | import Spectrum.LedgerSync.Protocol.Client 35 | ( Block ) 36 | 37 | import Cardano.Crypto.Hashing 38 | ( decodeHash, hashToBytes ) 39 | import Ouroboros.Consensus.HardFork.Combinator.AcrossEras 40 | ( getOneEraHash ) 41 | import Ouroboros.Consensus.HardFork.Combinator 42 | ( OneEraHash(OneEraHash) ) 43 | import Ouroboros.Consensus.Cardano.Block 44 | ( CardanoEras ) 45 | 46 | data ConcretePoint = ConcretePoint 47 | { slot :: SlotNo 48 | , hash :: ConcreteHash 49 | } deriving (Generic, Eq, Show, FromDhall, ToJSON, FromJSON) 50 | 51 | toPoint :: ConcretePoint -> Point Block 52 | toPoint ConcretePoint{slot, hash=ConcreteHash hash} = BlockPoint{atSlot=slot, withHash=hash} 53 | 54 | fromPoint :: Point Block -> ConcretePoint 55 | fromPoint BlockPoint{atSlot, withHash} = ConcretePoint{slot=atSlot, hash=ConcreteHash withHash} 56 | 57 | instance FromDhall SlotNo where 58 | autoWith _ = D.Decoder{..} 59 | where 60 | extract (NaturalLit nat) = pure $ SlotNo $ fromIntegral nat 61 | extract expr = D.typeError expected expr 62 | 63 | expected = pure Natural 64 | 65 | newtype ConcreteHash = ConcreteHash (HeaderHash Block) 66 | deriving newtype (Eq, Show) 67 | 68 | instance FromDhall ConcreteHash where 69 | autoWith _ = D.Decoder{..} 70 | where 71 | extract (TextLit (Chunks [] t)) = either (D.extractError . T.pack) (pure . ConcreteHash) $ oneEraHashFromString t 72 | extract expr = D.typeError expected expr 73 | 74 | expected = pure Text 75 | 76 | instance ToJSON ConcreteHash where 77 | toJSON (ConcreteHash hh) = toJSON . encodeBase16 . fromShort . getOneEraHash $ hh 78 | 79 | instance FromJSON ConcreteHash where 80 | parseJSON (String s) = either fail (pure . ConcreteHash) $ oneEraHashFromString s 81 | parseJSON _ = fail "Expected a string" 82 | 83 | oneEraHashFromString :: D.Text -> Either String (OneEraHash (CardanoEras crypto)) 84 | oneEraHashFromString = 85 | either (const $ Left "Invalid hash") (pure . OneEraHash . toShort . hashToBytes) . decodeHash 86 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/LedgerSync.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.LedgerSync 2 | ( LedgerSync(..) 3 | , mkLedgerSync 4 | ) where 5 | 6 | import RIO ( (<&>), void ) 7 | 8 | import Spectrum.Prelude.Context 9 | ( MonadReader, HasType, askContext ) 10 | import Spectrum.Prelude.UnliftIO 11 | ( UnliftIO ) 12 | 13 | import GHC.Num ( naturalToInt ) 14 | 15 | import Control.Monad.IO.Class 16 | ( MonadIO ) 17 | import Control.Monad.Class.MonadSTM 18 | ( MonadSTM (..), TQueue ) 19 | import Control.Monad.Class.MonadThrow 20 | ( MonadThrow (throwIO), MonadMask ) 21 | import Control.Monad.Class.MonadST 22 | ( MonadST ) 23 | import Control.Monad.Class.MonadAsync 24 | ( MonadAsync ) 25 | import Control.Monad.Class.MonadFork 26 | ( MonadFork (forkIO) ) 27 | 28 | import Control.Tracer 29 | ( Tracer (..), natTracer) 30 | 31 | import System.Logging.Hlog 32 | ( Logging(Logging, errorM, warnM, infoM, debugM), MakeLogging(..) ) 33 | 34 | import Spectrum.LedgerSync.Data.LedgerUpdate 35 | ( LedgerUpdate ) 36 | import qualified Spectrum.LedgerSync.Data.LedgerUpdate as Update 37 | import qualified Spectrum.LedgerSync.Data.MempoolUpdate as MempoolUpdate 38 | import Spectrum.LedgerSync.Protocol.Data.ChainSync 39 | ( RequestNextResponse(RollBackward, RollForward, block, point), 40 | RequestNext(RequestNext), 41 | ChainSyncResponse(RequestNextRes, FindIntersectRes), 42 | ChainSyncRequest(RequestNextReq, FindIntersectReq), 43 | FindIntersect(FindIntersect), 44 | FindIntersectResponse (IntersectionFound) ) 45 | 46 | import Ouroboros.Consensus.Block 47 | ( StandardHash ) 48 | import Cardano.Network.Protocol.NodeToClient.Trace 49 | ( TraceClient ) 50 | import Ouroboros.Network.Block 51 | ( Point ) 52 | import Ouroboros.Network.NodeToClient.Version 53 | ( NodeToClientVersionData (NodeToClientVersionData) ) 54 | import Ouroboros.Consensus.Cardano.Block 55 | ( GenTx ) 56 | 57 | import Spectrum.LedgerSync.Config 58 | ( NetworkParameters(NetworkParameters, slotsPerEpoch, networkMagic), 59 | NodeSocketConfig(..) ) 60 | import Spectrum.LedgerSync.Exception 61 | ( ChainSyncInitFailed(ChainSyncInitFailed) ) 62 | import Spectrum.LedgerSync.Protocol.ChainSync 63 | ( mkChainSyncClient ) 64 | import Spectrum.LedgerSync.Protocol.MempoolSync 65 | import Spectrum.LedgerSync.Protocol.Data.MempoolSync 66 | import Spectrum.LedgerSync.Protocol.Client 67 | ( mkClient, connectClient, Block, Clients(..) ) 68 | import Spectrum.Prelude.HigherKind 69 | ( FunctorK(..) ) 70 | import Spectrum.LedgerSync.Data.MempoolUpdate (MempoolUpdate) 71 | import Debug.Trace () 72 | 73 | data LedgerSync m = LedgerSync 74 | { pull :: m (LedgerUpdate Block) 75 | , tryPull :: m (Maybe (LedgerUpdate Block)) 76 | , pullTx :: m (MempoolUpdate Block) 77 | , seekTo :: Point Block -> m () 78 | } 79 | 80 | instance FunctorK LedgerSync where 81 | fmapK trans LedgerSync{..} = 82 | LedgerSync 83 | { pull = trans pull 84 | , tryPull = trans tryPull 85 | , pullTx = trans pullTx 86 | , seekTo = trans . seekTo 87 | } 88 | 89 | mkLedgerSync 90 | :: forall m env. 91 | ( MonadAsync m 92 | , MonadFork m 93 | , MonadMask m 94 | , MonadST m 95 | , MonadIO m 96 | , MonadReader env m 97 | , HasType NodeSocketConfig env 98 | , HasType NetworkParameters env 99 | , HasType (MakeLogging m m) env 100 | ) 101 | => UnliftIO m 102 | -> Tracer m TraceClient 103 | -> m (LedgerSync m) 104 | mkLedgerSync unliftIO tr = do 105 | MakeLogging{..} <- askContext 106 | NodeSocketConfig{nodeSocketPath, maxInFlight} <- askContext 107 | NetworkParameters{slotsPerEpoch,networkMagic} <- askContext 108 | 109 | l@Logging{..} <- forComponent "LedgerSync" 110 | (outQ, inQ) <- atomically $ (,) <$> newTQueue <*> newTQueue 111 | 112 | (outQTxMonitor, inQTxMonitor) <- atomically $ (,) <$> newTQueue <*> newTQueue 113 | let 114 | chainSyncClient = mkChainSyncClient (naturalToInt maxInFlight) outQ inQ 115 | txMonitorClient = mkTxMonitorClient outQTxMonitor inQTxMonitor 116 | clients = Clients chainSyncClient txMonitorClient 117 | 118 | client = mkClient unliftIO slotsPerEpoch clients 119 | versions = NodeToClientVersionData networkMagic 120 | 121 | infoM @String "Connecting Node Client" 122 | void $ forkIO $ connectClient (natTracer unliftIO tr) client versions nodeSocketPath 123 | infoM @String "LedgerSync initialized successfully" 124 | pure LedgerSync 125 | { pull = pull' outQ inQ 126 | , tryPull = tryPull' outQ inQ 127 | , pullTx = pullTx' outQTxMonitor inQTxMonitor 128 | , seekTo = seekTo' l outQ inQ 129 | } 130 | 131 | -- | Set chain sync state to the desired block 132 | seekTo' 133 | :: (MonadSTM m, MonadThrow m, StandardHash block) 134 | => Logging m 135 | -> TQueue m (ChainSyncRequest block) 136 | -> TQueue m (ChainSyncResponse block) 137 | -> Point block 138 | -> m () 139 | seekTo' Logging{..} outQ inQ point = do 140 | atomically $ writeTQueue outQ $ FindIntersectReq $ FindIntersect [point] 141 | res <- atomically $ readTQueue inQ 142 | case res of 143 | FindIntersectRes (IntersectionFound _ _) -> 144 | infoM @String"IntersectionFound!" >> pure () 145 | _ -> 146 | infoM @String"An attempt to seed to an unknown point" >> (throwIO $ ChainSyncInitFailed $ "An attempt to seed to an unknown point " <> show point) 147 | 148 | pull' 149 | :: MonadSTM m 150 | => TQueue m (ChainSyncRequest block) 151 | -> TQueue m (ChainSyncResponse block) 152 | -> m (LedgerUpdate block) 153 | pull' outQ inQ = do 154 | atomically $ writeTQueue outQ $ RequestNextReq RequestNext 155 | atomically $ readTQueue inQ <&> extractUpdate 156 | 157 | pullTx' 158 | :: MonadSTM m 159 | => TQueue m (MempoolRequest block) 160 | -> TQueue m (MempoolResponse block) 161 | -> m (MempoolUpdate block) 162 | pullTx' outQ inQ = do 163 | atomically $ writeTQueue outQ RequestNextTx 164 | atomically $ readTQueue inQ <&> extractMempoolUpdate 165 | 166 | tryPull' 167 | :: MonadSTM m 168 | => TQueue m (ChainSyncRequest block) 169 | -> TQueue m (ChainSyncResponse block) 170 | -> m (Maybe (LedgerUpdate block)) 171 | tryPull' outQ inQ = do 172 | atomically $ writeTQueue outQ $ RequestNextReq RequestNext 173 | atomically $ tryReadTQueue inQ <&> (<&> extractUpdate) 174 | 175 | extractUpdate :: ChainSyncResponse block -> LedgerUpdate block 176 | extractUpdate (RequestNextRes RollForward{block}) = Update.RollForward block 177 | extractUpdate (RequestNextRes RollBackward{point}) = Update.RollBackward point 178 | extractUpdate _ = undefined 179 | 180 | extractMempoolUpdate :: MempoolResponse block -> MempoolUpdate block 181 | extractMempoolUpdate (NewTx tx slot) = MempoolUpdate.NewTx tx slot 182 | extractMempoolUpdate _ = undefined 183 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/LedgerSync/Config.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.LedgerSync.Config 2 | ( NodeSocketConfig(..) 3 | , NetworkParameters(..) 4 | , parseNetworkParameters 5 | ) where 6 | 7 | import RIO ( (>=>), Natural ) 8 | import RIO.FilePath (replaceFileName) 9 | 10 | import System.Exit (die) 11 | import GHC.Generics ( Generic ) 12 | 13 | import Dhall (FromDhall) 14 | 15 | import qualified Data.Yaml as Yaml 16 | import qualified Data.Yaml.Pretty as Yaml 17 | 18 | import Data.Aeson.Lens 19 | ( key, _Integer, _String ) 20 | import Data.Time.Format.ISO8601 21 | ( iso8601ParseM ) 22 | import Data.Profunctor.Unsafe 23 | ( ( #. ) ) 24 | import Data.Text.Encoding 25 | ( decodeUtf8 ) 26 | import qualified Data.Text as T 27 | import Data.Monoid 28 | ( First (getFirst, First) ) 29 | 30 | import Control.Monad.Trans.Except 31 | ( ExceptT (ExceptT), runExceptT, withExceptT, throwE ) 32 | import Control.Applicative 33 | ( Const (getConst, Const) ) 34 | 35 | import Cardano.Chain.Slotting 36 | ( EpochSlots (..) ) 37 | import Ouroboros.Consensus.BlockchainTime.WallClock.Types 38 | ( SystemStart (..) ) 39 | import Ouroboros.Network.Magic 40 | ( NetworkMagic (..) ) 41 | 42 | data NodeSocketConfig = NodeSocketConfig 43 | { nodeSocketPath :: !FilePath 44 | , maxInFlight :: !Natural 45 | } deriving (Generic, FromDhall) 46 | 47 | data NetworkParameters = NetworkParameters 48 | { networkMagic :: !NetworkMagic 49 | , systemStart :: !SystemStart 50 | , slotsPerEpoch :: !EpochSlots 51 | } deriving (Generic, Eq, Show) 52 | 53 | parseNetworkParameters :: FilePath -> IO NetworkParameters 54 | parseNetworkParameters configFile = runOrDie $ do 55 | config <- decodeYaml configFile 56 | let 57 | genesisFiles = (,) 58 | <$> config ^? key "ByronGenesisFile" . _String 59 | <*> config ^? key "ShelleyGenesisFile" . _String 60 | case genesisFiles of 61 | Nothing -> 62 | throwE "Missing 'ByronGenesisFile' and/or 'ShelleyGenesisFile' from Cardano's configuration?" 63 | Just (T.unpack -> byronGenesisFile, T.unpack -> shelleyGenesisFile) -> do 64 | byronGenesis <- decodeYaml (replaceFileName configFile byronGenesisFile) 65 | shelleyGenesis <- decodeYaml (replaceFileName configFile shelleyGenesisFile) 66 | let 67 | params = (,,) 68 | <$> (shelleyGenesis ^? key "networkMagic" . _Integer) 69 | <*> (iso8601ParseM . T.unpack =<< shelleyGenesis ^? key "systemStart" . _String) 70 | <*> (byronGenesis ^? key "protocolConsts" . key "k" . _Integer) 71 | case params of 72 | Nothing -> do 73 | let prettyYaml = T.unpack $ decodeUtf8 (Yaml.encodePretty Yaml.defConfig shelleyGenesis) 74 | throwE $ unwords 75 | [ "Couldn't find (or failed to parse) required network" 76 | , "parameters (networkMagic, systemStart and/or epochLength)" 77 | , "in genesis file: \n" <> prettyYaml 78 | ] 79 | Just (nm, ss, k) -> 80 | return NetworkParameters 81 | { networkMagic = 82 | NetworkMagic (fromIntegral nm) 83 | , systemStart = 84 | SystemStart ss 85 | , slotsPerEpoch = 86 | EpochSlots (fromIntegral $ 10 * k) 87 | } 88 | where 89 | runOrDie :: ExceptT String IO a -> IO a 90 | runOrDie = runExceptT >=> either die pure 91 | 92 | prettyParseException :: Yaml.ParseException -> String 93 | prettyParseException e = "Failed to decode JSON (or YAML) file: " <> show e 94 | 95 | decodeYaml :: FilePath -> ExceptT String IO Yaml.Value 96 | decodeYaml = withExceptT prettyParseException . ExceptT . Yaml.decodeFileEither 97 | 98 | infixl 8 ^? 99 | (^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a 100 | s ^? l = getFirst (fmof l (First #. Just) s) 101 | where fmof l' f = getConst #. l' (Const #. f) 102 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/LedgerSync/Data/LedgerUpdate.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.LedgerSync.Data.LedgerUpdate where 2 | 3 | import Ouroboros.Consensus.Block 4 | ( Point ) 5 | 6 | data LedgerUpdate block 7 | = RollForward block 8 | | RollBackward (Point block) 9 | deriving (Eq, Show) 10 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/LedgerSync/Data/MempoolUpdate.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.LedgerSync.Data.MempoolUpdate where 2 | 3 | import Ouroboros.Consensus.Cardano.Block 4 | ( GenTx ) 5 | import Cardano.Api 6 | ( SlotNo ) 7 | 8 | data MempoolUpdate block = 9 | NewTx (GenTx block) SlotNo -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/LedgerSync/Exception.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.LedgerSync.Exception 2 | ( ChainSyncInitFailed(..) 3 | ) where 4 | 5 | import Control.Exception (Exception) 6 | 7 | newtype ChainSyncInitFailed = ChainSyncInitFailed String 8 | deriving stock (Show, Eq) 9 | deriving anyclass Exception 10 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/LedgerSync/Protocol/ChainSync.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.LedgerSync.Protocol.ChainSync 2 | ( mkChainSyncClient 3 | ) where 4 | 5 | import RIO 6 | ( (<&>), ($>), liftIO ) 7 | 8 | import Control.Monad 9 | ( guard ) 10 | import Control.Monad.Class.MonadSTM 11 | ( MonadSTM (..), TQueue ) 12 | 13 | import Network.TypedProtocol.Pipelined 14 | ( Nat (..), natToInt ) 15 | import Ouroboros.Network.Block 16 | ( Point (..), Tip (..) ) 17 | import Ouroboros.Network.Protocol.ChainSync.ClientPipelined 18 | ( ChainSyncClientPipelined (..) 19 | , ClientPipelinedStIdle (..) 20 | , ClientPipelinedStIntersect (..) 21 | , ClientStNext (..) 22 | ) 23 | 24 | import Spectrum.LedgerSync.Protocol.Data.ChainSync 25 | ( RequestNextResponse(RollBackward, RollForward) 26 | , RequestNext(RequestNext) 27 | , FindIntersectResponse(IntersectionNotFound, IntersectionFound) 28 | , FindIntersect(FindIntersect, points) 29 | , ChainSyncResponse(..) 30 | , ChainSyncRequest(..) 31 | ) 32 | 33 | type MaxInFlight = Int 34 | 35 | mkChainSyncClient 36 | :: forall m block. MonadSTM m 37 | => MaxInFlight 38 | -- ^ Max number of requests allowed to be in-flight / pipelined 39 | -> TQueue m (ChainSyncRequest block) 40 | -- ^ Incoming request queue 41 | -> TQueue m (ChainSyncResponse block) 42 | -- ^ Outgoing response queue 43 | -> ChainSyncClientPipelined block (Point block) (Tip block) m () 44 | mkChainSyncClient maxInFlight incomingQ outgoingQ = 45 | ChainSyncClientPipelined $ clientStIdle Zero 46 | where 47 | pull :: m (ChainSyncRequest block) 48 | pull = atomically (readTQueue incomingQ) 49 | 50 | tryPull :: m (Maybe (ChainSyncRequest block)) 51 | tryPull = atomically (tryReadTQueue incomingQ) 52 | 53 | clientStIdle :: Nat n -> m (ClientPipelinedStIdle n block (Point block) (Tip block) m ()) 54 | clientStIdle Zero = pull <&> \case 55 | RequestNextReq RequestNext -> 56 | let 57 | collect = CollectResponse 58 | (Just $ clientStIdle (Succ Zero)) 59 | (clientStNext Zero) 60 | in SendMsgRequestNextPipelined collect 61 | 62 | FindIntersectReq FindIntersect{points} -> 63 | SendMsgFindIntersect points clientStIntersect 64 | 65 | clientStIdle n@(Succ prev) = tryPull >>= \case 66 | -- If there's no immediate incoming message, we take this opportunity to 67 | -- wait and collect one response. 68 | Nothing -> 69 | pure $ CollectResponse Nothing (clientStNext prev) 70 | 71 | -- Yet, if we have already received a new message from the client, we 72 | -- prioritize it and pipeline it right away unless there are already too 73 | -- many requests in flights. 74 | Just (RequestNextReq RequestNext) -> do 75 | let collect = CollectResponse (guard (natToInt n < maxInFlight) $> clientStIdle (Succ n)) (clientStNext n) 76 | pure $ SendMsgRequestNextPipelined collect 77 | 78 | Just (FindIntersectReq _FindIntersect) -> -- 'FindIntersect' requests cannot be interleaved with 'RequestNext'. 79 | clientStIdle n 80 | 81 | clientStNext :: Nat n -> ClientStNext n block (Point block) (Tip block) m () 82 | clientStNext n = 83 | ClientStNext 84 | { recvMsgRollForward = \block tip -> do 85 | atomically $ writeTQueue outgoingQ $ RequestNextRes $ RollForward block tip 86 | clientStIdle n 87 | , recvMsgRollBackward = \point tip -> do 88 | atomically $ writeTQueue outgoingQ $ RequestNextRes $ RollBackward point tip 89 | clientStIdle n 90 | } 91 | 92 | clientStIntersect :: ClientPipelinedStIntersect block (Point block) (Tip block) m () 93 | clientStIntersect = ClientPipelinedStIntersect 94 | { recvMsgIntersectFound = \point tip -> do 95 | atomically $ writeTQueue outgoingQ $ FindIntersectRes $ IntersectionFound point tip 96 | clientStIdle Zero 97 | , recvMsgIntersectNotFound = \tip -> do 98 | atomically $ writeTQueue outgoingQ $ FindIntersectRes $ IntersectionNotFound tip 99 | clientStIdle Zero 100 | } 101 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/LedgerSync/Protocol/Data/ChainSync.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | 3 | module Spectrum.LedgerSync.Protocol.Data.ChainSync 4 | ( ChainSyncRequest(..) 5 | , ChainSyncResponse(..) 6 | , FindIntersect(..) 7 | , FindIntersectResponse(..) 8 | , RequestNext(..) 9 | , RequestNextResponse(..) 10 | ) where 11 | 12 | import GHC.Generics 13 | ( Generic ) 14 | 15 | import Ouroboros.Network.Block 16 | ( Point (..), Tip (..) ) 17 | 18 | data ChainSyncRequest block 19 | = FindIntersectReq (FindIntersect block) 20 | | RequestNextReq RequestNext 21 | deriving (Generic, Show) 22 | 23 | data ChainSyncResponse block 24 | = FindIntersectRes (FindIntersectResponse block) 25 | | RequestNextRes (RequestNextResponse block) 26 | deriving (Generic, Show) 27 | 28 | data FindIntersect block 29 | = FindIntersect { points :: [Point block] } 30 | deriving (Generic, Show, Eq) 31 | 32 | data FindIntersectResponse block 33 | = IntersectionFound { point :: Point block, tip :: Tip block } 34 | | IntersectionNotFound { tip :: Tip block } 35 | deriving (Generic, Show) 36 | 37 | data RequestNext 38 | = RequestNext 39 | deriving (Generic, Show, Eq) 40 | 41 | data RequestNextResponse block 42 | = RollForward { block :: block, tip :: Tip block } 43 | | RollBackward { point :: Point block, tip :: Tip block } 44 | deriving (Generic, Show) 45 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/LedgerSync/Protocol/Data/MempoolSync.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.LedgerSync.Protocol.Data.MempoolSync where 2 | 3 | import GHC.Generics 4 | 5 | import Ouroboros.Consensus.Cardano.Block 6 | ( GenTx ) 7 | import Cardano.Api 8 | ( SlotNo ) 9 | 10 | data MempoolRequest block = 11 | RequestNextTx 12 | deriving (Generic, Show, Eq) 13 | 14 | data MempoolResponse block = 15 | NewTx (GenTx block) SlotNo 16 | deriving (Generic) -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/LedgerSync/Protocol/MempoolSync.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Spectrum.LedgerSync.Protocol.MempoolSync where 4 | 5 | import Control.Monad.Class.MonadSTM 6 | ( MonadSTM (..), TQueue ) 7 | import Spectrum.LedgerSync.Protocol.Data.MempoolSync 8 | ( MempoolRequest(..), MempoolResponse(..) ) 9 | import Ouroboros.Network.Protocol.LocalTxMonitor.Client 10 | import Ouroboros.Consensus.Ledger.SupportsMempool 11 | ( GenTx, GenTxId ) 12 | import Cardano.Api.Shelley 13 | ( SlotNo ) 14 | 15 | mkTxMonitorClient 16 | :: forall m block. MonadSTM m 17 | => TQueue m (MempoolRequest block) 18 | -> TQueue m (MempoolResponse block) 19 | -> LocalTxMonitorClient (GenTxId block) (GenTx block) SlotNo m () 20 | mkTxMonitorClient incomingQ outgoingQ = 21 | LocalTxMonitorClient clientStIdle 22 | where 23 | pull :: m (MempoolRequest block) 24 | pull = do 25 | atomically (readTQueue incomingQ) 26 | 27 | clientStIdle :: m (ClientStIdle (GenTxId block) (GenTx block) SlotNo m ()) 28 | clientStIdle = pull >>= (\case 29 | RequestNextTx -> do 30 | pure $ SendMsgAcquire $ \slot -> clientStAcquired (Just RequestNextTx) slot 31 | _ -> clientStIdle 32 | ) 33 | 34 | clientStAcquired :: Maybe (MempoolRequest block) -> SlotNo -> m (ClientStAcquired (GenTxId block) (GenTx block) SlotNo m ()) 35 | clientStAcquired prevRequestM slotNo = case prevRequestM of 36 | Just prevRequest -> executeRequest prevRequest 37 | Nothing -> pull >>= executeRequest 38 | where 39 | executeRequest = \case 40 | RequestNextTx -> do 41 | pure $ SendMsgNextTx $ \case 42 | Nothing -> do 43 | pure $ SendMsgAwaitAcquire $ const $ clientStAcquired (Just RequestNextTx) slotNo 44 | Just tx -> do 45 | atomically $ writeTQueue outgoingQ $ NewTx tx slotNo 46 | clientStAcquired Nothing slotNo 47 | _ -> clientStAcquired Nothing slotNo 48 | -------------------------------------------------------------------------------- /ledger-sync/src/Spectrum/Topic.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.Topic 2 | ( ReadTopic(..) 3 | , WriteTopic(..) 4 | , OneToOneTopic(..) 5 | , mkOneToOneTopic 6 | , mkNoopTopic 7 | ) where 8 | 9 | import qualified Control.Concurrent.Chan.Unagi as U 10 | 11 | import Control.Concurrent.Chan.Unagi.NoBlocking 12 | ( newChan, readChan, writeChan, Next (Next, Pending), Stream (tryReadNext), streamChan, tryReadChan, Element (tryRead), isActive, InChan, OutChan) 13 | import RIO 14 | ( MonadIO(..), MonadTrans (lift), MonadThrow (throwM), catch, SomeException, throwIO ) 15 | import Streamly.Prelude as S 16 | ( IsStream, MonadAsync, repeatM, nil, fromPure, fromEffect, after, before ) 17 | import Control.Exception 18 | ( BlockedIndefinitelyOnMVar(BlockedIndefinitelyOnMVar) ) 19 | import System.Logging.Hlog 20 | import Control.Concurrent 21 | ( yield ) 22 | 23 | newtype ReadTopic s m a = ReadTopic 24 | { upstream :: s m a 25 | } 26 | 27 | newtype WriteTopic m a = WriteTopic 28 | { publish :: a -> m () 29 | } 30 | 31 | data OneToOneTopic s m a = OneToOneTopic (ReadTopic s m a) (WriteTopic m a) 32 | 33 | mkOneToOneTopic 34 | :: forall s f m a. (IsStream s, MonadAsync m, MonadIO f, MonadThrow m, Show a) 35 | => Logging m 36 | -> f (OneToOneTopic s m a) 37 | mkOneToOneTopic logging@Logging{..} = liftIO $ do 38 | (inc, outc) <- newChan 39 | pure $ OneToOneTopic 40 | (ReadTopic . S.repeatM . liftIO $ readChan yield outc) 41 | (WriteTopic $ liftIO . writeChan inc) 42 | 43 | mkNoopTopic 44 | :: forall s m a. (IsStream s, Applicative m) 45 | => (ReadTopic s m a, WriteTopic m a) 46 | mkNoopTopic = (ReadTopic S.nil, WriteTopic . const . pure $ ()) -------------------------------------------------------------------------------- /network-api/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /network-api/network-api.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: network-api 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: ErgoLabs 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | DerivingStrategies 23 | BangPatterns 24 | BinaryLiterals 25 | ConstraintKinds 26 | DataKinds 27 | DefaultSignatures 28 | DeriveDataTypeable 29 | DeriveFoldable 30 | DeriveFunctor 31 | DeriveGeneric 32 | DeriveTraversable 33 | DoAndIfThenElse 34 | EmptyDataDecls 35 | ExistentialQuantification 36 | FlexibleContexts 37 | FlexibleInstances 38 | FunctionalDependencies 39 | GADTs 40 | GeneralizedNewtypeDeriving 41 | InstanceSigs 42 | KindSignatures 43 | LambdaCase 44 | MultiParamTypeClasses 45 | MultiWayIf 46 | NamedFieldPuns 47 | PartialTypeSignatures 48 | PatternGuards 49 | PolyKinds 50 | RankNTypes 51 | RecordWildCards 52 | ScopedTypeVariables 53 | StandaloneDeriving 54 | TupleSections 55 | TypeFamilies 56 | TypeSynonymInstances 57 | ViewPatterns 58 | TypeApplications 59 | 60 | ghc-options: -Wall 61 | -Wcompat 62 | -Wincomplete-record-updates 63 | -Wincomplete-uni-patterns 64 | -Wpartial-fields 65 | -Wredundant-constraints 66 | -Wunused-packages 67 | -Widentities 68 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 69 | 70 | library 71 | import: base, project-config 72 | 73 | hs-source-dirs: src 74 | 75 | exposed-modules: NetworkAPI.Types 76 | NetworkAPI.Service 77 | 78 | build-depends: 79 | rio, 80 | transformers-except, 81 | serialise, 82 | cardano-tx, 83 | plutus-chain-index, 84 | prettyprinter, 85 | cardano-slotting, 86 | ouroboros-network, 87 | mtl, 88 | http-conduit, 89 | plutus-ledger, 90 | bytestring, 91 | aeson, 92 | servant, 93 | singletons, 94 | either, 95 | aeson-gadt-th, 96 | some, 97 | dependent-sum-template, 98 | containers, 99 | freer-simple, 100 | extra, 101 | cardano-api, 102 | text, 103 | dhall, 104 | quickblue, 105 | retry, 106 | hlog, 107 | network-mux, 108 | exceptions -------------------------------------------------------------------------------- /network-api/src/NetworkAPI/Service.hs: -------------------------------------------------------------------------------- 1 | module NetworkAPI.Service 2 | ( NodeError(..) 3 | , CardanoNetwork(..) 4 | , mkCardanoNetwork 5 | ) where 6 | 7 | import RIO 8 | 9 | import qualified Data.Text as Text 10 | 11 | import System.Logging.Hlog (Logging(..), MakeLogging(..)) 12 | 13 | import Cardano.Api hiding (SocketPath) 14 | import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Client as Net.Tx 15 | 16 | import NetworkAPI.Types (SocketPath(..), SystemEnv(..)) 17 | 18 | data NodeError 19 | = NodeConnectionFailed 20 | | EraMismatch 21 | | WrongMode 22 | | TxSubmissionFailed Text 23 | deriving (Show, Exception) 24 | 25 | data CardanoNetwork f era = CardanoNetwork 26 | { getSystemEnv :: f SystemEnv 27 | , submitTx :: Tx era -> f () 28 | } 29 | 30 | mkCardanoNetwork 31 | :: (MonadIO i, MonadThrow f, MonadUnliftIO f) 32 | => MakeLogging i f 33 | -> CardanoEra era 34 | -> ConsensusModeParams CardanoMode 35 | -> NetworkId 36 | -> SocketPath 37 | -> i (CardanoNetwork f era) 38 | mkCardanoNetwork MakeLogging{..} cera cModeParams networkId (SocketPath sockPath) = do 39 | logging <- forComponent "CardanoNetwork" 40 | let conn = LocalNodeConnectInfo cModeParams networkId sockPath 41 | emptyMVar <- newEmptyMVar 42 | pure $ CardanoNetwork 43 | { getSystemEnv = withAsyncCache emptyMVar $ getSystemEnv' cera conn 44 | , submitTx = submitTx' logging cera conn 45 | } 46 | 47 | getSystemEnv' 48 | :: (MonadIO f, MonadThrow f) 49 | => CardanoEra era 50 | -> LocalNodeConnectInfo CardanoMode 51 | -> f SystemEnv 52 | getSystemEnv' era conn = 53 | case (cardanoEraStyle era, toEraInMode era CardanoMode) of 54 | (ShelleyBasedEra sbe, Just eInMode) -> 55 | either (const $ throwM EraMismatch) pure =<< 56 | either (const $ throwM NodeConnectionFailed) pure =<< 57 | liftIO (executeLocalStateQueryExpr conn Nothing $ \_ntcVersion -> do 58 | pparams <- queryExpr $ QueryInEra eInMode $ QueryInShelleyBasedEra sbe QueryProtocolParameters 59 | eraHistory <- queryExpr $ QueryEraHistory CardanoModeIsMultiEra 60 | systemStart <- queryExpr QuerySystemStart 61 | stakePools <- queryExpr . QueryInEra eInMode . QueryInShelleyBasedEra sbe $ QueryStakePools 62 | 63 | pure $ do 64 | pparams' <- pparams 65 | pools' <- stakePools 66 | pure $ SystemEnv pparams' systemStart pools' eraHistory 67 | ) 68 | _ -> throwM WrongMode 69 | 70 | submitTx' 71 | :: (MonadIO f, MonadThrow f) 72 | => Logging f 73 | -> CardanoEra era 74 | -> LocalNodeConnectInfo CardanoMode 75 | -> Tx era 76 | -> f () 77 | submitTx' Logging{..} era conn tx = 78 | case toEraInMode era CardanoMode of 79 | Just eraInMode -> do 80 | let txInMode = TxInMode tx eraInMode 81 | res <- liftIO $ submitTxToNodeLocal conn txInMode 82 | case res of 83 | Net.Tx.SubmitSuccess -> infoM @String "Transaction successfully submitted." 84 | Net.Tx.SubmitFail reason -> 85 | case reason of 86 | TxValidationErrorInMode err _ -> throwM $ TxSubmissionFailed $ Text.pack $ show err 87 | TxValidationEraMismatch _ -> throwM EraMismatch 88 | _ -> throwM WrongMode 89 | 90 | withAsyncCache 91 | :: (MonadIO f, MonadUnliftIO f) 92 | => MVar a 93 | -> f a 94 | -> f a 95 | withAsyncCache mVar fa = do 96 | mVarReadResult <- liftIO $ tryTakeMVar mVar 97 | case mVarReadResult of 98 | Nothing -> do 99 | a <- fa 100 | _ <- liftIO $ tryPutMVar mVar a 101 | return a 102 | Just env -> async (updateAsyncCache' mVar fa) >> pure env 103 | 104 | updateAsyncCache' 105 | :: (MonadIO f, MonadUnliftIO f) 106 | => MVar a 107 | -> f a 108 | -> f () 109 | updateAsyncCache' mVar fa = fa >>= (void . liftIO . tryPutMVar mVar) 110 | -------------------------------------------------------------------------------- /network-api/src/NetworkAPI/Types.hs: -------------------------------------------------------------------------------- 1 | module NetworkAPI.Types 2 | ( SocketPath(..) 3 | , SystemEnv(..) 4 | ) where 5 | 6 | import Data.Set (Set) 7 | 8 | import Cardano.Api (CardanoMode, EraHistory) 9 | import Cardano.Api.Shelley (ProtocolParameters, PoolId) 10 | import Cardano.Slotting.Time (SystemStart) 11 | 12 | newtype SocketPath = SocketPath FilePath 13 | deriving newtype (Eq, Show) 14 | 15 | data SystemEnv = SystemEnv 16 | { pparams :: ProtocolParameters 17 | , sysstart :: SystemStart 18 | , pools :: Set PoolId 19 | , eraHistory :: EraHistory CardanoMode 20 | } 21 | -------------------------------------------------------------------------------- /nix/default.nix: -------------------------------------------------------------------------------- 1 | let 2 | # Pratically, the only needed dependency is the plutus repository. 3 | sources = import ./sources.nix { inherit pkgs; }; 4 | 5 | # We're going to get everything from the main plutus repository. This ensures 6 | # we're using the same version of multiple dependencies such as nipxkgs, 7 | # haskell-nix, cabal-install, compiler-nix-name, etc. 8 | plutus = import sources.plutus-apps {}; 9 | pkgs = plutus.pkgs; 10 | 11 | haskell-nix = pkgs.haskell-nix; 12 | 13 | cardano-dex-sdk = import ./pkgs { 14 | inherit pkgs haskell-nix sources plutus; 15 | }; 16 | 17 | in 18 | { 19 | inherit pkgs cardano-dex-sdk; 20 | } 21 | -------------------------------------------------------------------------------- /nix/lib/ci.nix: -------------------------------------------------------------------------------- 1 | { pkgs }: 2 | 3 | let 4 | # Generic nixpkgs, use *only* for lib functions that are stable across versions 5 | lib = pkgs.lib; 6 | in 7 | rec { 8 | # Borrowed from https://github.com/cachix/ghcide-nix/pull/4/files#diff-70bfff902f4dec33e545cac10ee5844d 9 | # Tweaked to use builtins.mapAttrs instead of needing the one from nixpkgs lib 10 | /* 11 | dimension: name -> attrs -> function -> attrs 12 | where 13 | function: keyText -> value -> attrsOf package 14 | 15 | WARNING: Attribute names must not contain periods ("."). 16 | See https://github.com/NixOS/nix/issues/3088 17 | 18 | NOTE: The dimension name will be picked up by agent and web ui soon. 19 | 20 | Specifies a dimension of the build matrix. For example 21 | 22 | dimension "Example" { 23 | withP = { p = true; } 24 | withoutP = { p = false; } 25 | } (key: # either "withP" or "withoutP" 26 | { p }: # either p = true or p = false 27 | myProject p 28 | ) 29 | 30 | evaluates roughly to 31 | 32 | { 33 | withP = myProject true; 34 | withoutP = myProject false; 35 | } 36 | 37 | Use nested calls for multiple dimensions. 38 | 39 | Example: 40 | 41 | dimension "System" { 42 | "x86_64-linux" = {}; 43 | # ... 44 | }: (system: {}: 45 | 46 | dimension "Nixpkgs release" ( 47 | { 48 | "nixpkgs-19_03".nixpkgs = someSource 49 | } // optionalAttrs (system != "...") { 50 | "nixpkgs-unstable".nixpkgs = someOtherSource 51 | } 52 | ) (_key: { nixpkgs }: 53 | 54 | myProject system nixpkgs 55 | 56 | ) 57 | ) 58 | 59 | evaluates roughly to 60 | 61 | { 62 | x86_64-linux.nixpkgs-19_03 = myProject "x86_64-linux" someSource; 63 | x86_64-linux.nixpkgs-unstable = myProject "x86_64-linux" someOtherSource; 64 | ... 65 | } 66 | 67 | If you need to make references across attributes, you can do so by binding 68 | the result. Wherever you write 69 | 70 | dimension "My dimension" {} (key: value: f1 key value) 71 | 72 | You can also write 73 | 74 | let 75 | myDimension = dimension "My dimension" {} (key: value: f2 key value myDimension) 76 | in 77 | myDimension 78 | 79 | This example builds a single test runner to reuse across releases: 80 | 81 | let 82 | overlay = 83 | testRunnerPkgs: self: super: { 84 | # ... 85 | }; 86 | myProject = 87 | { nixpkgs, 88 | pkgs ? import nixpkgs { overlays = [ overlay ]; }, 89 | testRunnerPkgs ? pkgs 90 | }: pkgs; 91 | in 92 | 93 | let 94 | latest = "nixpkgs-19_03"; 95 | releases = 96 | dimension "Nixpkgs release" 97 | { 98 | nixpkgs-18_09.nixpkgs = someSource 99 | nixpkgs-19_03.nixpkgs = someOtherSource 100 | } 101 | (_key: { nixpkgs }: 102 | 103 | myProject { 104 | inherit nixpkgs; 105 | testRunnerPkgs = releases."${latest}"; 106 | } 107 | 108 | ); 109 | in releases; 110 | 111 | */ 112 | dimension = name: attrs: f: 113 | builtins.mapAttrs 114 | (k: v: 115 | let o = f k v; 116 | in o // { recurseForDerivations = o.recurseForDerivations or true; } 117 | ) 118 | attrs 119 | // { meta.dimension.name = name; }; 120 | 121 | /* 122 | Takes an attribute set and returns all the paths to derivations within it, i.e. 123 | derivationPaths { a = { b = ; }; c = ; } == [ "a.b" "c" ] 124 | This can be used with 'attrByPath' or the 'constitutents' of an aggregate Hydra job. 125 | */ 126 | derivationPaths = 127 | let 128 | names = x: lib.filter (n: n != "recurseForDerivations" && n != "meta") (builtins.attrNames x); 129 | go = nameSections: attrs: 130 | builtins.concatMap 131 | (n: 132 | let 133 | v = builtins.getAttr n attrs; 134 | newNameSections = nameSections ++ [ n ]; 135 | in 136 | if pkgs.lib.isDerivation v 137 | then [ (builtins.concatStringsSep "." newNameSections) ] 138 | else if builtins.isAttrs v 139 | then go newNameSections v 140 | else [ ] 141 | ) 142 | (names attrs); 143 | in 144 | go [ ]; 145 | 146 | # Creates an aggregate job with the given name from every derivation in the attribute set. 147 | derivationAggregate = name: attrs: pkgs.releaseTools.aggregate { 148 | inherit name; 149 | constituents = derivationPaths attrs; 150 | }; 151 | 152 | # A filter for removing packages that aren't supported on the current platform 153 | # according to 'meta.platforms'. 154 | platformFilterGeneric = pkgs: system: 155 | # This needs to use the correct nixpkgs version so all the systems line up 156 | let 157 | lib = pkgs.lib; 158 | platform = lib.systems.elaborate { inherit system; }; 159 | # Can't just default to [] for platforms, since no meta.platforms 160 | # means "all platforms" not "no platforms" 161 | in 162 | drv: 163 | if drv ? meta && drv.meta ? platforms then 164 | lib.any (lib.meta.platformMatch platform) drv.meta.platforms 165 | else true; 166 | 167 | # Hydra doesn't like these attributes hanging around in "jobsets": it thinks they're jobs! 168 | stripAttrsForHydra = filterAttrsOnlyRecursive (n: _: n != "recurseForDerivations" && n != "dimension"); 169 | 170 | # Keep derivations and attrsets with 'recurseForDerivations'. This ensures that we match the 171 | # derivations that Hercules will see, and prevents Hydra from trying to pick up all sorts of bad stuff 172 | # (like attrsets that contain themselves!). 173 | filterDerivations = filterAttrsOnlyRecursive (n: attrs: lib.isDerivation attrs || attrs.recurseForDerivations or false); 174 | 175 | # A version of 'filterAttrsRecursive' that doesn't recurse into derivations. This prevents us from going into an infinite 176 | # loop with the 'out' attribute on derivations. 177 | # TODO: Surely this shouldn't be necessary. I think normal 'filterAttrsRecursive' will effectively cause infinite loops 178 | # if you keep derivations and your predicate forces the value of the attribute, as this then triggers a loop on the 179 | # 'out' attribute. Weird. 180 | filterAttrsOnlyRecursive = pred: set: 181 | lib.listToAttrs ( 182 | lib.concatMap 183 | (name: 184 | let v = set.${name}; in 185 | if pred name v then [ 186 | (lib.nameValuePair name ( 187 | if builtins.isAttrs v && !lib.isDerivation v then filterAttrsOnlyRecursive pred v 188 | else v 189 | )) 190 | ] else [ ] 191 | ) 192 | (builtins.attrNames set) 193 | ); 194 | 195 | # Takes an array of systems and returns a `name: system` AttrSet 196 | # filterSystems :: [ string ] -> AttrSet 197 | filterSystems = systems: lib.filterAttrs (_: v: builtins.elem v systems) { 198 | linux = "x86_64-linux"; 199 | darwin = "x86_64-darwin"; 200 | }; 201 | } 202 | -------------------------------------------------------------------------------- /nix/pkgs/default.nix: -------------------------------------------------------------------------------- 1 | { pkgs 2 | , sources 3 | , plutus 4 | , haskell-nix 5 | }: 6 | let 7 | gitignore-nix = pkgs.callPackage plutus."gitignore.nix" { }; 8 | 9 | compiler-nix-name = plutus.plutus-apps.haskell.compiler-nix-name; 10 | 11 | haskell = pkgs.callPackage ./haskell { 12 | inherit gitignore-nix sources haskell-nix; 13 | inherit compiler-nix-name; # Use the same GHC version as plutus 14 | inherit (pkgs) libsodium-vrf; 15 | }; 16 | 17 | hlint = plutus.plutus-apps.hlint; 18 | 19 | cabal-install = plutus.plutus-apps.cabal-install; 20 | 21 | stylish-haskell = plutus.plutus-apps.stylish-haskell; 22 | 23 | haskell-language-server = plutus.plutus-apps.haskell-language-server; 24 | 25 | cardano-repo-tool = plutus.plutus-apps.cardano-repo-tool; 26 | in 27 | { 28 | inherit haskell hlint cabal-install stylish-haskell haskell-language-server cardano-repo-tool; 29 | } 30 | -------------------------------------------------------------------------------- /nix/pkgs/haskell/default.nix: -------------------------------------------------------------------------------- 1 | { lib 2 | , haskell-nix 3 | , gitignore-nix 4 | , sources 5 | , compiler-nix-name 6 | , libsodium-vrf 7 | }: 8 | let 9 | # The Hackage index-state from cabal.project 10 | index-state = 11 | let 12 | parseIndexState = rawCabalProject: 13 | let 14 | indexState = lib.lists.concatLists ( 15 | lib.lists.filter (l: l != null) 16 | (map (l: builtins.match "^index-state: *(.*)" l) 17 | (lib.splitString "\n" rawCabalProject))); 18 | in 19 | lib.lists.head (indexState ++ [ null ]); 20 | in 21 | parseIndexState (builtins.readFile ../../../cabal.project); 22 | 23 | # The haskell project created by haskell-nix.cabalProject' 24 | project = import ./haskell.nix { 25 | inherit lib haskell-nix compiler-nix-name gitignore-nix libsodium-vrf; 26 | }; 27 | 28 | # All the packages defined by our project, including dependencies 29 | packages = project.hsPkgs; 30 | 31 | # Just the packages in the project 32 | projectPackages = haskell-nix.haskellLib.selectProjectPackages packages; 33 | in 34 | rec { 35 | inherit project projectPackages packages; 36 | } 37 | -------------------------------------------------------------------------------- /nix/pkgs/haskell/haskell.nix: -------------------------------------------------------------------------------- 1 | ############################################################################ 2 | # Builds Haskell packages with Haskell.nix 3 | ############################################################################ 4 | { haskell-nix 5 | , gitignore-nix 6 | , compiler-nix-name 7 | , lib 8 | , libsodium-vrf 9 | }: 10 | 11 | let 12 | project = haskell-nix.project { 13 | # 'cleanGit' cleans a source directory based on the files known by git 14 | src = haskell-nix.haskellLib.cleanGit { 15 | name = "cardano-dex-sdk"; 16 | src = ../../../.; 17 | }; 18 | 19 | inherit compiler-nix-name; 20 | 21 | sha256map = { 22 | "https://github.com/input-output-hk/plutus-apps"."19e1e6cf0e567c0222d723b57438e9a8efa878fb" = "CIuI/Nz7O67ljOHDg7UBbXgWuIE7VPRdPX4VK0/DI3A="; 23 | "https://github.com/Quid2/flat"."ee59880f47ab835dbd73bea0847dab7869fc20d8" = "1lrzknw765pz2j97nvv9ip3l1mcpf2zr4n56hwlz0rk7wq7ls4cm"; 24 | "https://github.com/input-output-hk/purescript-bridge"."47a1f11825a0f9445e0f98792f79172efef66c00" = "/SbnmXrB9Y2rrPd6E79Iu5RDaKAKozIl685HQ4XdQTU="; 25 | "https://github.com/input-output-hk/servant-purescript"."44e7cacf109f84984cd99cd3faf185d161826963" = "DH9ISydu5gxvN4xBuoXVv1OhYCaqGOtzWlACdJ0H64I="; 26 | "https://github.com/input-output-hk/cardano-crypto"."f73079303f663e028288f9f4a9e08bcca39a923e" = "2Fipex/WjIRMrvx6F3hjJoAeMtFd2wGnZECT0kuIB9k="; 27 | "https://github.com/input-output-hk/cardano-base"."0f3a867493059e650cda69e20a5cbf1ace289a57" = "4b0keLjRaVSdEwfBXB1iT3QPlsutdxSltGfBufT4Clw="; 28 | "https://github.com/input-output-hk/cardano-prelude"."bb4ed71ba8e587f672d06edf9d2e376f4b055555" = "kgX3DKyfjBb8/XcDEd+/adlETsFlp5sCSurHWgsFAQI="; 29 | "https://github.com/input-output-hk/typed-protocols"."181601bc3d9e9d21a671ce01e0b481348b3ca104" = "5Wof5yTKb12EPY6B8LfapX18xNZZpF+rvhnQ88U6KdM="; 30 | "https://github.com/input-output-hk/io-sim"."57e888b1894829056cb00b7b5785fdf6a74c3271" = "TviSvCBEYtlKEo9qJmE8pCE25nMjDi8HeIAFniunaM8="; 31 | "https://github.com/vshabanov/ekg-json"."00ebe7211c981686e65730b7144fbf5350462608" = "VT8Ur585TCn03P2TVi6t92v2Z6tl8vKijICjse6ocv8="; 32 | "https://github.com/input-output-hk/cardano-addresses"."b7273a5d3c21f1a003595ebf1e1f79c28cd72513" = "91F9+ckA3lBCE4dAVLDnMSpwRLa7zRUEEBYEHv0sOYk="; 33 | "https://github.com/input-output-hk/cardano-wallet"."18a931648550246695c790578d4a55ee2f10463e" = "3Rnj/g3KLzOW5YSieqsUa9IF1Td22Eskk5KuVsOFgEQ="; 34 | "https://github.com/input-output-hk/ouroboros-network"."cb9eba406ceb2df338d8384b35c8addfe2067201" = "3ElbHM1B5u1QD0aes1KbaX2FxKJzU05H0OzJ36em1Bg="; 35 | "https://github.com/input-output-hk/iohk-monitoring-framework"."066f7002aac5a0efc20e49643fea45454f226caa" = "0ia5UflYEmBYepj2gkJy9msknklI0UPtUavMEGwk3Wg="; 36 | "https://github.com/input-output-hk/quickcheck-dynamic"."c272906361471d684440f76c297e29ab760f6a1e" = "TioJQASNrQX6B3n2Cv43X2olyT67//CFQqcpvNW7N60="; 37 | "https://github.com/input-output-hk/cardano-node"."8762a10efe3f9f97939e3cb05edaf04250456702" = "LwoQejDDA9P7dbl8z3nFbEJDDim0Y7oHUOgf4EH2Xig="; 38 | "https://github.com/input-output-hk/ekg-forward"."297cd9db5074339a2fb2e5ae7d0780debb670c63" = "jwj/gh/A/PXhO6yVESV27k4yx9I8Id8fTa3m4ofPnP0="; 39 | "https://github.com/input-output-hk/optparse-applicative"."7497a29cb998721a9068d5725d49461f2bba0e7a" = "1gvsrg925vynwgqwplgjmp53vj953qyh3wbdf34pw21c8r47w35r"; 40 | "https://github.com/input-output-hk/Win32-network"."3825d3abf75f83f406c1f7161883c438dac7277d" = "19wahfv726fa3mqajpqdqhnl9ica3xmf68i254q45iyjcpj1psqx"; 41 | "https://github.com/input-output-hk/goblins"."cde90a2b27f79187ca8310b6549331e59595e7ba" = "17c88rbva3iw82yg9srlxjv2ia5wjb9cyqw44hik565f5v9svnyg"; 42 | "https://github.com/input-output-hk/plutus"."a56c96598b4b25c9e28215214d25189331087244" = "coD/Kpl7tutwXb6ukQCH5XojBjquYkW7ob0BWZtdpok="; 43 | "https://github.com/input-output-hk/cardano-ledger"."c7c63dabdb215ebdaed8b63274965966f2bf408f" = "zTQbMOGPD1Oodv6VUsfF6NUiXkbN8SWI98W3Atv4wbI="; 44 | "https://github.com/input-output-hk/plutus-apps"."593ffafa59dd30ad28cfaf144c526c66328595d2" = "CIuI/Nz7O67ljOHDg7UBbXgWuIE7VPRdPX4VK0/DI3A="; 45 | "https://github.com/input-output-hk/hedgehog-extras"."714ee03a5a786a05fc57ac5d2f1c2edce4660d85" = "6KQFEzb9g2a0soVvwLKESEbA+a8ygpROcMr6bkatROE="; 46 | "https://github.com/ergolabs/cardano-dex-contracts"."2fb44f444897d84e313ceb4d3d467441385802dd" = "Kih0IS6Ty3EnXlgqAyF04nWIWJAnHOEVfraebh5RsNI="; 47 | "https://github.com/ergolabs/hlog"."19dfa3a6e696a3f63fc3539cd6b7a3fc4d999853" = "Lvmj1oLuXmktrboXh/BrXqLPf8FxSCXIf99GnBXu0Bk="; 48 | "https://github.com/daleiz/rocksdb-haskell"."109af08f95b40f458d4933e3725ecb3e59337c39" = "1i1ya491fapa0g96527krarv0w0iybizqcz518741iw06hhpikiy"; 49 | }; 50 | 51 | modules = [ 52 | { 53 | packages = { 54 | ergo-hs-common.package.buildable = false; 55 | spectrum.package.buildable = false; 56 | cardano-tx.package.buildable = false; 57 | dex-core.package.buildable = false; 58 | quickblue.package.buildable = false; 59 | wallet-api.package.buildable = false; 60 | network-api.package.buildable = false; 61 | submit-api.package.buildable = false; 62 | datum-keeper-client.package.buildable = false; 63 | algebra-core.package.buildable = false; 64 | spectrum-prelude.package.buildable = false; 65 | ledger-sync.package.buildable = false; 66 | 67 | # Broken due to haddock errors. Refer to https://github.com/input-output-hk/plutus/blob/master/nix/pkgs/haskell/haskell.nix 68 | plutus-ledger.doHaddock = false; 69 | plutus-use-cases.doHaddock = false; 70 | 71 | # See https://github.com/input-output-hk/iohk-nix/pull/488 72 | cardano-crypto-praos.components.library.pkgconfig = lib.mkForce [ [ libsodium-vrf ] ]; 73 | cardano-crypto-class.components.library.pkgconfig = lib.mkForce [ [ libsodium-vrf ] ]; 74 | }; 75 | } 76 | ]; 77 | }; 78 | in 79 | project -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "haskellNix": { 3 | "branch": "master", 4 | "description": "Alternative Haskell Infrastructure for Nixpkgs", 5 | "homepage": "https://input-output-hk.github.io/haskell.nix", 6 | "owner": "input-output-hk", 7 | "repo": "haskell.nix", 8 | "rev": "edcaa0f19ba8d7a392852406751deb0fd953e805", 9 | "sha256": "0lqv33l46kzfv577pzl4c1zxp5gc75fmyis7mzv4llyrm3jkmwlg", 10 | "type": "tarball", 11 | "url": "https://github.com/input-output-hk/haskell.nix/archive/edcaa0f19ba8d7a392852406751deb0fd953e805.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "plutus-apps": { 15 | "branch": "main", 16 | "description": "The Plutus application platform", 17 | "homepage": "", 18 | "owner": "input-output-hk", 19 | "repo": "plutus-apps", 20 | "rev": "eb69d69cb5f4fda6b4994ad737a0e4da98c19d20", 21 | "sha256": "0xj039xlw4algivbd6hi26wyglm9qi2n6hmddzvnsw90wjzy9aa6", 22 | "type": "tarball", 23 | "url": "https://github.com/input-output-hk/plutus-apps/archive/eb69d69cb5f4fda6b4994ad737a0e4da98c19d20.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: name: spec: 10 | let 11 | name' = sanitizeName name + "-src"; 12 | in 13 | if spec.builtin or true then 14 | builtins_fetchurl { inherit (spec) url sha256; name = name'; } 15 | else 16 | pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; 17 | 18 | fetch_tarball = pkgs: name: spec: 19 | let 20 | name' = sanitizeName name + "-src"; 21 | in 22 | if spec.builtin or true then 23 | builtins_fetchTarball { name = name'; inherit (spec) url sha256; } 24 | else 25 | pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; 26 | 27 | fetch_git = name: spec: 28 | let 29 | ref = 30 | if spec ? ref then spec.ref else 31 | if spec ? branch then "refs/heads/${spec.branch}" else 32 | if spec ? tag then "refs/tags/${spec.tag}" else 33 | abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; 34 | in 35 | builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; 36 | 37 | fetch_local = spec: spec.path; 38 | 39 | fetch_builtin-tarball = name: throw 40 | ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. 41 | $ niv modify ${name} -a type=tarball -a builtin=true''; 42 | 43 | fetch_builtin-url = name: throw 44 | ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. 45 | $ niv modify ${name} -a type=file -a builtin=true''; 46 | 47 | # 48 | # Various helpers 49 | # 50 | 51 | # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 52 | sanitizeName = name: 53 | ( 54 | concatMapStrings (s: if builtins.isList s then "-" else s) 55 | ( 56 | builtins.split "[^[:alnum:]+._?=-]+" 57 | ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) 58 | ) 59 | ); 60 | 61 | # The set of packages used when specs are fetched using non-builtins. 62 | mkPkgs = sources: system: 63 | let 64 | sourcesNixpkgs = 65 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; 66 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 67 | hasThisAsNixpkgsPath = == ./.; 68 | in 69 | if builtins.hasAttr "nixpkgs" sources 70 | then sourcesNixpkgs 71 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 72 | import {} 73 | else 74 | abort 75 | '' 76 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 77 | add a package called "nixpkgs" to your sources.json. 78 | ''; 79 | 80 | # The actual fetching function. 81 | fetch = pkgs: name: spec: 82 | 83 | if ! builtins.hasAttr "type" spec then 84 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 85 | else if spec.type == "file" then fetch_file pkgs name spec 86 | else if spec.type == "tarball" then fetch_tarball pkgs name spec 87 | else if spec.type == "git" then fetch_git name spec 88 | else if spec.type == "local" then fetch_local spec 89 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball name 90 | else if spec.type == "builtin-url" then fetch_builtin-url name 91 | else 92 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 93 | 94 | # If the environment variable NIV_OVERRIDE_${name} is set, then use 95 | # the path directly as opposed to the fetched source. 96 | replace = name: drv: 97 | let 98 | saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; 99 | ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; 100 | in 101 | if ersatz == "" then drv else 102 | # this turns the string into an actual Nix path (for both absolute and 103 | # relative paths) 104 | if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; 105 | 106 | # Ports of functions for older nix versions 107 | 108 | # a Nix version of mapAttrs if the built-in doesn't exist 109 | mapAttrs = builtins.mapAttrs or ( 110 | f: set: with builtins; 111 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 112 | ); 113 | 114 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 115 | range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); 116 | 117 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 118 | stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); 119 | 120 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 121 | stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); 122 | concatMapStrings = f: list: concatStrings (map f list); 123 | concatStrings = builtins.concatStringsSep ""; 124 | 125 | # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 126 | optionalAttrs = cond: as: if cond then as else {}; 127 | 128 | # fetchTarball version that is compatible between all the versions of Nix 129 | builtins_fetchTarball = { url, name ? null, sha256 }@attrs: 130 | let 131 | inherit (builtins) lessThan nixVersion fetchTarball; 132 | in 133 | if lessThan nixVersion "1.12" then 134 | fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 135 | else 136 | fetchTarball attrs; 137 | 138 | # fetchurl version that is compatible between all the versions of Nix 139 | builtins_fetchurl = { url, name ? null, sha256 }@attrs: 140 | let 141 | inherit (builtins) lessThan nixVersion fetchurl; 142 | in 143 | if lessThan nixVersion "1.12" then 144 | fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 145 | else 146 | fetchurl attrs; 147 | 148 | # Create the final "sources" from the config 149 | mkSources = config: 150 | mapAttrs ( 151 | name: spec: 152 | if builtins.hasAttr "outPath" spec 153 | then abort 154 | "The values in sources.json should not have an 'outPath' attribute" 155 | else 156 | spec // { outPath = replace name (fetch config.pkgs name spec); } 157 | ) config.sources; 158 | 159 | # The "config" used by the fetchers 160 | mkConfig = 161 | { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null 162 | , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) 163 | , system ? builtins.currentSystem 164 | , pkgs ? mkPkgs sources system 165 | }: rec { 166 | # The sources, i.e. the attribute set of spec name to spec 167 | inherit sources; 168 | 169 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 170 | inherit pkgs; 171 | }; 172 | 173 | in 174 | mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } 175 | -------------------------------------------------------------------------------- /quickblue/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /quickblue/quickblue.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: quickblue 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | BangPatterns 23 | BinaryLiterals 24 | ConstraintKinds 25 | DataKinds 26 | DefaultSignatures 27 | DeriveDataTypeable 28 | DeriveFoldable 29 | DeriveFunctor 30 | DeriveGeneric 31 | DeriveTraversable 32 | DoAndIfThenElse 33 | EmptyDataDecls 34 | ExistentialQuantification 35 | FlexibleContexts 36 | FlexibleInstances 37 | FunctionalDependencies 38 | GADTs 39 | GeneralizedNewtypeDeriving 40 | InstanceSigs 41 | KindSignatures 42 | LambdaCase 43 | MultiParamTypeClasses 44 | MultiWayIf 45 | NamedFieldPuns 46 | PartialTypeSignatures 47 | PatternGuards 48 | PolyKinds 49 | RankNTypes 50 | RecordWildCards 51 | ScopedTypeVariables 52 | StandaloneDeriving 53 | TupleSections 54 | TypeFamilies 55 | TypeSynonymInstances 56 | ViewPatterns 57 | DerivingStrategies 58 | DuplicateRecordFields 59 | RecordWildCards 60 | 61 | ghc-options: -Wall 62 | -Wcompat 63 | -Wincomplete-record-updates 64 | -Wincomplete-uni-patterns 65 | -Wpartial-fields 66 | -Wredundant-constraints 67 | -Wunused-packages 68 | -Widentities 69 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 70 | 71 | library 72 | import: base, project-config 73 | 74 | hs-source-dirs: src 75 | 76 | exposed-modules: Explorer.Types 77 | Explorer.Models 78 | Explorer.Service 79 | Explorer.Config 80 | Explorer.Class 81 | 82 | build-depends: 83 | cardano-tx, 84 | http-conduit, 85 | plutus-ledger, 86 | plutus-ledger-api, 87 | bytestring, 88 | aeson, 89 | text, 90 | dhall, 91 | cardano-slotting, 92 | cardano-api, 93 | containers, 94 | plutus-tx, 95 | either, 96 | ouroboros-consensus, 97 | rio, 98 | cardano-crypto-class, 99 | ergo-hs-common, 100 | hlog -------------------------------------------------------------------------------- /quickblue/src/Explorer/Class.hs: -------------------------------------------------------------------------------- 1 | module Explorer.Class where 2 | 3 | class ToCardanoTx a target where 4 | toCardanoTx :: a -> target 5 | 6 | class FromExplorer a b where 7 | parseFromExplorer :: a -> Maybe b -------------------------------------------------------------------------------- /quickblue/src/Explorer/Config.hs: -------------------------------------------------------------------------------- 1 | module Explorer.Config where 2 | 3 | import GHC.Generics 4 | import Dhall 5 | 6 | newtype Uri = Uri { unUri :: String } 7 | deriving Generic 8 | deriving newtype (Show, FromDhall) 9 | 10 | data ExplorerConfig = ExplorerConfig 11 | { explorerUri :: Uri 12 | } deriving (Generic, Show) 13 | 14 | instance FromDhall ExplorerConfig -------------------------------------------------------------------------------- /quickblue/src/Explorer/Models.hs: -------------------------------------------------------------------------------- 1 | module Explorer.Models where 2 | 3 | import Data.Aeson.Types 4 | import qualified Data.Set as Set 5 | import qualified Data.Either.Combinators as EC 6 | import Data.String (IsString(..)) 7 | import qualified Data.Text as T 8 | import GHC.Generics 9 | 10 | import qualified Ledger as P 11 | import qualified Plutus.V1.Ledger.Value as Value 12 | import Ledger hiding (TxIn) 13 | import qualified PlutusTx.Builtins.Internal as BI 14 | import Explorer.Types 15 | import Explorer.Class 16 | import qualified CardanoTx.Models as Tx 17 | import CardanoTx.Value 18 | 19 | import qualified Cardano.Api as Api 20 | import Cardano.Api.Shelley (ProtocolParameters(..), PoolId, toPlutusData) 21 | import qualified Ouroboros.Consensus.HardFork.History as History 22 | import Ouroboros.Consensus.HardFork.History.Summary as HSummary 23 | import Ouroboros.Consensus.HardFork.History.EraParams as EP 24 | import Ouroboros.Consensus.BlockchainTime.WallClock.Types 25 | import Ouroboros.Consensus.Block 26 | import Ouroboros.Consensus.Util.Counting 27 | 28 | data SystemEnv = SystemEnv 29 | { pparams' :: ProtocolParameters 30 | , network' :: Api.NetworkId 31 | , sysstart' :: SystemStart 32 | , pools' :: Set.Set PoolId 33 | , eraHistory' :: Api.EraHistory Api.CardanoMode 34 | } deriving (Show, Generic) 35 | 36 | instance Show (Api.EraHistory Api.CardanoMode) where 37 | show _ = "Era history" 38 | 39 | instance FromJSON SystemEnv where 40 | parseJSON = withObject "SystemEnv" $ \o -> do 41 | pparams' <- o .: "pparams" 42 | sysstart' <- o .: "sysstart" 43 | return 44 | SystemEnv 45 | { pparams' = pparams' 46 | , network' = Api.Testnet $ Api.NetworkMagic 1097911063 47 | , sysstart' = sysstart' 48 | , pools' = Set.empty 49 | , eraHistory' = dummyEraHistory 50 | } 51 | 52 | dummyEraHistory :: Api.EraHistory Api.CardanoMode 53 | dummyEraHistory = 54 | Api.EraHistory 55 | Api.CardanoMode 56 | (History.mkInterpreter $ Summary $ NonEmptyOne $ 57 | EraSummary { 58 | eraStart = initBound 59 | , eraEnd = EraUnbounded 60 | , eraParams = EraParams { 61 | eraEpochSize = EpochSize 100 62 | , eraSlotLength = mkSlotLength 100 63 | , eraSafeZone = UnsafeIndefiniteSafeZone 64 | } 65 | } 66 | ) 67 | 68 | data Paging = Paging 69 | { offset :: Int 70 | , limit :: Int 71 | } deriving (Show, Generic, FromJSON) 72 | 73 | data Items a = Items 74 | { items :: [a] 75 | , total :: Int 76 | } deriving (Show, Generic, FromJSON) 77 | 78 | data FullTx = FullTx 79 | { blockHash :: BlockHash 80 | , blockIndex :: Int 81 | , globalIndex :: Gix 82 | , hash :: TxHash 83 | , inputs :: [FullTxIn] 84 | , outputs :: [FullTxOut] 85 | , timestamp :: Integer 86 | } deriving (Show, Generic, FromJSON) 87 | 88 | data FullTxIn = FullTxIn 89 | { out :: FullTxOut 90 | } deriving (Show, Generic, FromJSON) 91 | 92 | instance ToCardanoTx FullTxIn Tx.FullTxIn where 93 | toCardanoTx FullTxIn{..} = 94 | Tx.FullTxIn 95 | { fullTxInTxOut = toCardanoTx out 96 | -- actually, we don't need this field att all, so we keep it default 97 | , fullTxInType = ConsumeSimpleScriptAddress 98 | } 99 | 100 | data FullTxOut = FullTxOut 101 | { ref :: OutRef 102 | , txHash :: TxHash 103 | , index :: Int 104 | , globalIndex :: Gix 105 | , addr :: Addr 106 | , value :: [OutAsset] 107 | , dataHash :: Maybe P.DatumHash 108 | , data' :: Maybe P.Datum 109 | , spentByTxHash :: Maybe TxHash 110 | , refScriptHash :: Maybe P.ScriptHash 111 | } deriving (Show, Generic) 112 | 113 | instance FromJSON FullTxOut where 114 | parseJSON = withObject "quickblueFullTxOut" $ \o -> do 115 | ref <- OutRef <$> o .: "ref" 116 | txHash <- TxHash <$> o .: "txHash" 117 | index <- o .: "index" 118 | globalIndex <- Gix <$> o .: "globalIndex" 119 | addr <- Addr <$> o .: "addr" 120 | value <- o .: "value" 121 | dataHash <- o .:? "dataHash" 122 | rawDataM <- o .:? "data" 123 | spentByTxHash <- o .:? "spentByTxHash" 124 | refScriptHashM <- o .:? "refScriptHash" 125 | let 126 | jsonDataM = rawDataM >>= (EC.rightToMaybe . Api.scriptDataFromJson Api.ScriptDataJsonDetailedSchema) 127 | data' = fmap (P.Datum . BI.dataToBuiltinData . toPlutusData) jsonDataM 128 | refScriptHash = fmap ScriptHash refScriptHashM 129 | return FullTxOut{..} 130 | 131 | instance ToCardanoTx FullTxOut Tx.FullTxOut where 132 | toCardanoTx FullTxOut{..} = 133 | Tx.FullTxOut 134 | { fullTxOutRef = toCardanoTx ref 135 | , fullTxOutAddress = toCardanoTx addr 136 | , fullTxOutValue = foldr (\a acc -> unionVal acc (toCardanoTx a)) mempty value 137 | , fullTxOutDatum = outDatum 138 | , fullTxOutScriptRef = refScriptHash 139 | } 140 | where 141 | outDatum = case (data', dataHash) of 142 | (Just d, _) -> Tx.KnownDatum d 143 | (_, Just dh) -> Tx.KnownDatumHash dh 144 | _ -> Tx.EmptyDatum 145 | 146 | data OutAsset = OutAsset 147 | { policy :: PolicyId 148 | , name :: AssetName 149 | , quantity :: Integer 150 | } deriving (Show, Generic) 151 | 152 | instance FromJSON OutAsset where 153 | parseJSON = withObject "quickblueOutAsset" $ \o -> do 154 | policy <- PolicyId <$> o .: "policyId" 155 | name <- AssetName <$> o .: "name" 156 | quantity <- o .: "quantity" 157 | return OutAsset{..} 158 | 159 | instance ToCardanoTx OutAsset P.Value where 160 | toCardanoTx OutAsset{..} = Value.singleton p n quantity 161 | where 162 | p = fromString $ T.unpack $ unPolicyId policy 163 | n = fromString $ T.unpack $ unAssetName name -------------------------------------------------------------------------------- /quickblue/src/Explorer/Service.hs: -------------------------------------------------------------------------------- 1 | module Explorer.Service where 2 | 3 | import Control.Monad.IO.Class 4 | import Data.ByteString.Char8 as Data 5 | import Data.Function 6 | import Data.Aeson 7 | import qualified Data.Text as T 8 | import Network.HTTP.Simple 9 | 10 | import Explorer.Types 11 | import Explorer.Models 12 | import Explorer.Config 13 | 14 | import Ledger ( TxOutRef, txOutRefId, txOutRefIdx ) 15 | import Prelude hiding (Ordering) 16 | import System.Logging.Hlog (Logging (Logging, debugM), MakeLogging (MakeLogging, forComponent)) 17 | 18 | data Explorer f = Explorer 19 | { getOutput :: TxOutRef -> f (Maybe FullTxOut) 20 | , getUnspentOutputs :: Gix -> Limit -> Ordering -> f (Items FullTxOut) 21 | , getUnspentOutputsByPCred :: PaymentCred -> Paging -> f (Items FullTxOut) 22 | , getSystemEnv :: f SystemEnv 23 | , getTxs :: Paging -> Ordering -> f (Items FullTx) 24 | } 25 | 26 | mkExplorer :: (Monad i, MonadIO f) => MakeLogging i f -> ExplorerConfig -> i (Explorer f) 27 | mkExplorer MakeLogging{..} conf = do 28 | logging <- forComponent "explorer" 29 | pure $ Explorer 30 | { getOutput = getOutput' logging conf 31 | , getUnspentOutputs = getUnspentOutputs' logging conf 32 | , getUnspentOutputsByPCred = getUnspentOutputsByPCred' logging conf 33 | , getSystemEnv = getSystemEnv' logging conf 34 | , getTxs = getTxs' logging conf 35 | } 36 | 37 | getOutput' :: MonadIO f => Logging f -> ExplorerConfig -> TxOutRef -> f (Maybe FullTxOut) 38 | getOutput' logging conf ref = 39 | mkGetRequest logging conf $ "/cardano/v1/outputs/" ++ renderTxOutRef ref 40 | 41 | getUnspentOutputs' :: MonadIO f => Logging f -> ExplorerConfig -> Gix -> Limit -> Ordering -> f (Items FullTxOut) 42 | getUnspentOutputs' logging conf minIndex limit ordering = 43 | mkGetRequest logging conf $ "/cardano/v1/outputs/unspent/indexed?minIndex=" ++ show minIndex ++ "&limit=" ++ show limit ++ "&ordering=" ++ show ordering 44 | 45 | getUnspentOutputsByPCred' :: MonadIO f => Logging f -> ExplorerConfig -> PaymentCred -> Paging -> f (Items FullTxOut) 46 | getUnspentOutputsByPCred' logging conf pcred Paging{..} = 47 | mkGetRequest logging conf $ "/cardano/v1/outputs/unspent/byPaymentCred/" ++ T.unpack (unPaymentCred pcred) ++ "/?offset=" ++ show offset ++ "&limit=" ++ show limit 48 | 49 | getSystemEnv' :: MonadIO f => Logging f -> ExplorerConfig -> f SystemEnv 50 | getSystemEnv' logging conf = mkGetRequest logging conf "/cardano/v1/networkParams" 51 | 52 | getTxs' :: MonadIO f => Logging f -> ExplorerConfig -> Paging -> Ordering -> f (Items FullTx) 53 | getTxs' logging conf Paging{..} ordering = 54 | mkGetRequest logging conf $ "/cardano/v1/transactions/?offset=" ++ show offset ++ "&limit=" ++ show limit ++ "&ordering=" ++ show ordering 55 | 56 | mkGetRequest :: (MonadIO f, FromJSON a, Show a) => Logging f -> ExplorerConfig -> String -> f a 57 | mkGetRequest Logging{..} ExplorerConfig{..} path = do 58 | let request = parseRequest_ (unUri explorerUri) & setRequestPath (Data.pack path) 59 | 60 | response <- httpJSON request 61 | 62 | let parsedResponse = getResponseBody response 63 | 64 | debugM ("Response is: " ++ show parsedResponse) 65 | 66 | pure parsedResponse 67 | 68 | renderTxOutRef :: TxOutRef -> [Char] 69 | renderTxOutRef ref = (show . txOutRefId $ ref) ++ T.unpack txOutRefSep ++ (show . txOutRefIdx $ ref) 70 | -------------------------------------------------------------------------------- /quickblue/src/Explorer/Types.hs: -------------------------------------------------------------------------------- 1 | module Explorer.Types where 2 | 3 | import Data.Aeson (FromJSON, ToJSON) 4 | import Data.Text hiding (words, head) 5 | import Data.String (IsString(..)) 6 | import Data.Maybe (fromMaybe) 7 | import GHC.Generics 8 | 9 | import qualified Ledger as P 10 | import Explorer.Class 11 | import qualified CardanoTx.Address as Core 12 | 13 | -- Bech32 encoded and rendered address 14 | newtype Addr = Addr { unAddr :: Text } 15 | deriving (Eq, Generic) 16 | deriving newtype (Show, FromJSON) 17 | 18 | instance ToCardanoTx Addr P.Address where 19 | toCardanoTx (Addr addr) = fromMaybe (error "Impossible") (Core.readShellyAddress addr) 20 | 21 | -- Payment credential encoded as a hex string 22 | newtype PaymentCred = PaymentCred { unPaymentCred :: Text } 23 | deriving (Eq, Generic) 24 | deriving newtype (Show, FromJSON) 25 | 26 | -- Output reference string composed of TxHash and OutIndex : {TxHash}:{OutIndex} 27 | newtype OutRef = OutRef { unOutRef :: Text } 28 | deriving (Eq, Generic) 29 | deriving newtype (Show, FromJSON) 30 | 31 | txOutRefSep :: Text 32 | txOutRefSep = ":" 33 | 34 | instance ToCardanoTx OutRef P.TxOutRef where 35 | toCardanoTx (OutRef ref) = P.TxOutRef (fromString $ unpack hash) (read $ unpack index) 36 | where [hash, index] = splitOn txOutRefSep ref 37 | 38 | -- A hex-encoded hash of minting policy 39 | newtype PolicyId = PolicyId { unPolicyId :: Text } 40 | deriving (Eq, Generic) 41 | deriving newtype (Show, FromJSON) 42 | 43 | -- Asset name represented as a utf-8 string 44 | newtype AssetName = AssetName { unAssetName :: Text } 45 | deriving (Eq, Generic) 46 | deriving newtype (Show, FromJSON) 47 | 48 | -- 32 bytes hash represented as a hex string 49 | newtype Hash32 = Hash32 { unHash32 :: Text } 50 | deriving (Eq, Generic) 51 | deriving newtype (Show, FromJSON) 52 | 53 | -- 28 bytes hash represented as a hex string 54 | newtype Hash28 = Hash28 { unHash28 :: Text } 55 | deriving (Eq, Generic) 56 | deriving newtype (Show, FromJSON) 57 | 58 | -- TX hash32 represented as a hex string 59 | newtype TxHash = TxHash { unTxHash :: Text } 60 | deriving (Eq, Generic) 61 | deriving newtype (Show, FromJSON) 62 | 63 | -- Block hash32 represented as a hex string 64 | newtype BlockHash = BlockHash { unBlockHash :: Text } 65 | deriving (Eq, Generic) 66 | deriving newtype (Show, FromJSON) 67 | 68 | -- A global index 69 | newtype Gix = Gix { unGix :: Integer } 70 | deriving (Eq, Generic) 71 | deriving newtype (Show, FromJSON, ToJSON) 72 | 73 | newtype Limit = Limit { unLimit :: Integer } 74 | deriving (Eq, Generic) 75 | deriving newtype (Show, FromJSON, ToJSON) 76 | 77 | data Ordering = Asc | Desc 78 | deriving (Eq, Generic, Show, FromJSON, ToJSON) 79 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | # The content of this file was partially copied from the equivalent file in the plutus repository. 2 | # It is used by IOHK's Hydra for CI (building the project, running the tests, etc.) 3 | # 4 | # Therefore, do not worry too much about the structure. 5 | let 6 | packages = import ./.; 7 | 8 | pkgs = packages.pkgs; 9 | haskellNix = pkgs.haskell-nix; 10 | 11 | # Just the packages in the project 12 | projectPackages = haskellNix.haskellLib.selectProjectPackages packages.project.hsPkgs; 13 | 14 | inherit (import ./nix/lib/ci.nix { inherit pkgs; }) dimension filterAttrsOnlyRecursive filterDerivations stripAttrsForHydra derivationAggregate; 15 | 16 | # Collects haskell derivations and builds an attrset: 17 | # 18 | # { library = { ... } 19 | # , tests = { ... } 20 | # , benchmarks = { ... } 21 | # , exes = { ... } 22 | # , checks = { ... } 23 | # } 24 | # Where each attribute contains an attribute set 25 | # with all haskell components of that type 26 | mkHaskellDimension = pkgs: haskellProjects: 27 | let 28 | # retrieve all checks from a Haskell package 29 | collectChecks = _: ps: pkgs.haskell-nix.haskellLib.collectChecks' ps; 30 | # retrieve all components of a Haskell package 31 | collectComponents = type: ps: pkgs.haskell-nix.haskellLib.collectComponents' type ps; 32 | # Given a component type and the retrieve function, retrieve components from haskell packages 33 | select = type: selector: (selector type) haskellProjects; 34 | # { component-type : retriever-fn } 35 | attrs = { 36 | "library" = collectComponents; 37 | "tests" = collectComponents; 38 | "benchmarks" = collectComponents; 39 | "exes" = collectComponents; 40 | "checks" = collectChecks; 41 | }; 42 | in 43 | dimension "Haskell component" attrs select; 44 | 45 | ciJobsets = stripAttrsForHydra (filterDerivations { 46 | shell = (import ./shell.nix); 47 | 48 | build = pkgs.recurseIntoAttrs (mkHaskellDimension pkgs projectPackages); 49 | }); 50 | in 51 | ciJobsets // { required = derivationAggregate "required-cardano-dex-sdk" ciJobsets; } 52 | 53 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | packages = import ./.; 3 | inherit (packages) pkgs cardano-dex-sdk; 4 | inherit (cardano-dex-sdk) haskell; 5 | 6 | in 7 | haskell.project.shellFor { 8 | 9 | shellHook = " 10 | export LC_CTYPE=C.UTF-8 11 | export LC_ALL=C.UTF-8 12 | export LANG=C.UTF-8 13 | "; 14 | 15 | withHoogle = false; 16 | 17 | nativeBuildInputs = with cardano-dex-sdk; [ 18 | hlint 19 | cabal-install 20 | haskell-language-server 21 | stylish-haskell 22 | pkgs.niv 23 | cardano-repo-tool 24 | pkgs.ghcid 25 | # HACK: This shouldn't need to be here. 26 | pkgs.lzma.dev 27 | ]; 28 | } 29 | -------------------------------------------------------------------------------- /spectrum-prelude/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /spectrum-prelude/spectrum-prelude.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: spectrum-prelude 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-backend 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | BangPatterns 23 | BinaryLiterals 24 | ConstraintKinds 25 | DataKinds 26 | DefaultSignatures 27 | DeriveDataTypeable 28 | DeriveFoldable 29 | DeriveFunctor 30 | DeriveGeneric 31 | DeriveTraversable 32 | DoAndIfThenElse 33 | EmptyDataDecls 34 | ExistentialQuantification 35 | FlexibleContexts 36 | FlexibleInstances 37 | FunctionalDependencies 38 | GADTs 39 | GeneralizedNewtypeDeriving 40 | InstanceSigs 41 | KindSignatures 42 | LambdaCase 43 | MultiParamTypeClasses 44 | MultiWayIf 45 | NamedFieldPuns 46 | NoImplicitPrelude 47 | PartialTypeSignatures 48 | PatternGuards 49 | PolyKinds 50 | RankNTypes 51 | RecordWildCards 52 | ScopedTypeVariables 53 | StandaloneDeriving 54 | TupleSections 55 | TypeFamilies 56 | TypeSynonymInstances 57 | ViewPatterns 58 | DuplicateRecordFields 59 | 60 | ghc-options: -Wall 61 | -Wcompat 62 | -Wincomplete-record-updates 63 | -Wincomplete-uni-patterns 64 | -Wpartial-fields 65 | -Wredundant-constraints 66 | -Wunused-packages 67 | -Widentities 68 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 69 | 70 | library 71 | import: base, project-config 72 | 73 | hs-source-dirs: src 74 | 75 | exposed-modules: Spectrum.Prelude.Context 76 | Spectrum.Prelude.UnliftIO 77 | Spectrum.Prelude.Throw 78 | 79 | build-depends: rio 80 | , aeson == 1.5.6.0 81 | , unliftio-core 82 | , io-classes 83 | , transformers 84 | , generic-lens 85 | , spectrum 86 | -------------------------------------------------------------------------------- /spectrum-prelude/src/Spectrum/Prelude/Context.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.Prelude.Context 2 | ( HasType 3 | , MonadReader 4 | , askContext 5 | , ask 6 | ) where 7 | 8 | import RIO ( MonadReader(ask), asks ) 9 | 10 | import Data.Generics.Product.Typed 11 | ( HasType, typed ) 12 | import Data.Generics.Internal.VL.Lens 13 | ( view ) 14 | 15 | askContext :: forall m env a. (HasType a env, MonadReader env m) => m a 16 | askContext = asks (view typed) 17 | -------------------------------------------------------------------------------- /spectrum-prelude/src/Spectrum/Prelude/Throw.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.Prelude.Throw 2 | ( throwEither 3 | , throwMaybe 4 | ) where 5 | 6 | import RIO 7 | ( Applicative(pure) 8 | , Maybe(Just) 9 | , Either(..) 10 | , MonadThrow(..) 11 | , Exception 12 | ) 13 | 14 | throwEither :: (MonadThrow f, Exception e) => Either e r -> f r 15 | throwEither (Left err) = throwM err 16 | throwEither (Right value) = pure value 17 | 18 | throwMaybe :: (MonadThrow f, Exception e) => e -> Maybe a -> f a 19 | throwMaybe _ (Just value) = pure value 20 | throwMaybe err _ = throwM err 21 | -------------------------------------------------------------------------------- /spectrum-prelude/src/Spectrum/Prelude/UnliftIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | module Spectrum.Prelude.UnliftIO 4 | ( UnliftIO 5 | ) where 6 | 7 | import RIO 8 | ( IO ) 9 | import Spectrum.Prelude.HigherKind 10 | ( type (~>) ) 11 | 12 | type UnliftIO m = m ~> IO 13 | -------------------------------------------------------------------------------- /spectrum/CHANGELOG.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spectrum-finance/cardano-dex-sdk-haskell/39d53d78fce1cf20b78b10bff9a9fc73b747cf2a/spectrum/CHANGELOG.md -------------------------------------------------------------------------------- /spectrum/spectrum.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: spectrum 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | BangPatterns 23 | BinaryLiterals 24 | ConstraintKinds 25 | DataKinds 26 | DefaultSignatures 27 | DeriveDataTypeable 28 | DeriveFoldable 29 | DeriveFunctor 30 | DeriveGeneric 31 | DeriveTraversable 32 | DoAndIfThenElse 33 | EmptyDataDecls 34 | ExistentialQuantification 35 | FlexibleContexts 36 | FlexibleInstances 37 | FunctionalDependencies 38 | GADTs 39 | GeneralizedNewtypeDeriving 40 | InstanceSigs 41 | KindSignatures 42 | LambdaCase 43 | MultiParamTypeClasses 44 | MultiWayIf 45 | NamedFieldPuns 46 | PartialTypeSignatures 47 | PatternGuards 48 | PolyKinds 49 | RankNTypes 50 | RecordWildCards 51 | ScopedTypeVariables 52 | StandaloneDeriving 53 | TupleSections 54 | TypeFamilies 55 | TypeSynonymInstances 56 | ViewPatterns 57 | DerivingStrategies 58 | DuplicateRecordFields 59 | RecordWildCards 60 | 61 | ghc-options: -Wall 62 | -Wcompat 63 | -Wincomplete-record-updates 64 | -Wincomplete-uni-patterns 65 | -Wpartial-fields 66 | -Wredundant-constraints 67 | -Wunused-packages 68 | -Widentities 69 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 70 | 71 | library 72 | import: base, project-config 73 | 74 | hs-source-dirs: src 75 | 76 | exposed-modules: Spectrum.Common.Persistence.Exception 77 | Spectrum.Common.Persistence.Serialization 78 | Spectrum.Prelude.HigherKind 79 | 80 | build-depends: 81 | bytestring, 82 | aeson, 83 | dhall, 84 | containers, 85 | either, 86 | rio, 87 | transformers -------------------------------------------------------------------------------- /spectrum/src/Spectrum/Common/Persistence/Exception.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.Common.Persistence.Exception 2 | ( StorageDeserializationFailed(..) 3 | ) where 4 | 5 | import Control.Exception (Exception) 6 | 7 | newtype StorageDeserializationFailed = StorageDeserializationFailed String 8 | deriving (Eq, Show) 9 | deriving anyclass Exception 10 | -------------------------------------------------------------------------------- /spectrum/src/Spectrum/Common/Persistence/Serialization.hs: -------------------------------------------------------------------------------- 1 | module Spectrum.Common.Persistence.Serialization 2 | ( serialize 3 | , deserializeM 4 | ) where 5 | 6 | import RIO 7 | ( ByteString, MonadThrow(..) ) 8 | 9 | import qualified Data.ByteString.Lazy as LBS 10 | import Data.Aeson 11 | ( ToJSON, encode, FromJSON, decode ) 12 | import Spectrum.Common.Persistence.Exception 13 | ( StorageDeserializationFailed(StorageDeserializationFailed) ) 14 | 15 | serialize :: ToJSON a => a -> ByteString 16 | serialize = LBS.toStrict . encode 17 | 18 | deserializeM :: (MonadThrow m, FromJSON a) => ByteString -> m a 19 | deserializeM = 20 | maybe 21 | (throwM $ StorageDeserializationFailed "Cannot parse data from ledger storage") 22 | pure . decode . LBS.fromStrict 23 | -------------------------------------------------------------------------------- /spectrum/src/Spectrum/Prelude/HigherKind.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | 3 | module Spectrum.Prelude.HigherKind 4 | ( type (~>) 5 | , FunctorK(..) 6 | , LiftK(..) 7 | ) where 8 | 9 | import Data.Kind 10 | ( Type ) 11 | import Control.Monad.Trans.Class 12 | ( MonadTrans(lift) ) 13 | 14 | type f ~> g = forall a. f a -> g a 15 | 16 | class FunctorK (alg :: (Type -> Type) -> Type) where 17 | fmapK :: (f ~> g) -> alg f -> alg g 18 | 19 | class LiftK (f :: Type -> Type) (g :: Type -> Type) where 20 | liftK :: f ~> g 21 | 22 | instance (MonadTrans g, Monad f) => LiftK f (g f) where 23 | liftK = lift -------------------------------------------------------------------------------- /submit-api/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /submit-api/src/SubmitAPI/Config.hs: -------------------------------------------------------------------------------- 1 | module SubmitAPI.Config 2 | ( FeePolicy(..) 3 | , CollateralPolicy(..) 4 | , TxAssemblyConfig(..) 5 | , DefaultChangeAddress(..) 6 | , unwrapChangeAddress 7 | ) where 8 | 9 | import qualified Dhall as D 10 | import Dhall.Core (Expr(..), Chunks(..)) 11 | import GHC.Generics 12 | 13 | import Ledger (Address) 14 | import qualified Cardano.Api as C 15 | import qualified Ledger.Tx.CardanoAPI as Interop 16 | import CardanoTx.Models (ChangeAddress(..)) 17 | 18 | data FeePolicy 19 | = Strict -- Require existing TX inputs to cover fee entirely 20 | | Balance -- Allow adding new inputs to cover fee 21 | deriving Generic 22 | 23 | instance D.FromDhall FeePolicy 24 | 25 | data CollateralPolicy 26 | = Ignore -- Ignore collateral inputs 27 | | Cover -- Allow adding new inputs to cover collateral 28 | deriving Generic 29 | 30 | instance D.FromDhall CollateralPolicy 31 | 32 | data TxAssemblyConfig = TxAssemblyConfig 33 | { feePolicy :: FeePolicy 34 | , collateralPolicy :: CollateralPolicy 35 | , deafultChangeAddr :: DefaultChangeAddress 36 | } deriving Generic 37 | 38 | instance D.FromDhall TxAssemblyConfig 39 | 40 | newtype DefaultChangeAddress = DefaultChangeAddress { getChangeAddr :: ChangeAddress } 41 | 42 | unwrapChangeAddress :: DefaultChangeAddress -> Address 43 | unwrapChangeAddress (DefaultChangeAddress (ChangeAddress addr)) = addr 44 | 45 | instance D.FromDhall DefaultChangeAddress where 46 | autoWith _ = D.Decoder{..} 47 | where 48 | extract (TextLit (Chunks [] t)) = 49 | maybe (D.extractError "Invalid Shelly Address") (pure . DefaultChangeAddress . ChangeAddress) (do 50 | caddr <- C.deserialiseAddress (C.AsAddress C.AsShelleyAddr) t 51 | either (const Nothing) pure (Interop.fromCardanoAddressInEra (C.shelleyAddressInEra caddr :: C.AddressInEra C.BabbageEra))) 52 | extract expr = D.typeError expected expr 53 | 54 | expected = pure Text 55 | -------------------------------------------------------------------------------- /submit-api/src/SubmitAPI/Service.hs: -------------------------------------------------------------------------------- 1 | module SubmitAPI.Service where 2 | 3 | import RIO 4 | import qualified Data.Set as Set 5 | import GHC.Natural (naturalToInteger) 6 | 7 | import qualified Cardano.Api as C 8 | import qualified Cardano.Api.Shelley as C 9 | import qualified Ledger as P 10 | import qualified Ledger.Ada as P 11 | import qualified Plutus.V1.Ledger.Credential as P 12 | 13 | import qualified CardanoTx.Models as Sdk 14 | import SubmitAPI.Config 15 | import qualified SubmitAPI.Internal.Transaction as Internal 16 | import SubmitAPI.Internal.Transaction (TxAssemblyError(..)) 17 | import NetworkAPI.Service hiding (submitTx) 18 | import qualified NetworkAPI.Service as Network 19 | import NetworkAPI.Types 20 | import WalletAPI.Utxos 21 | import WalletAPI.Vault 22 | 23 | data Transactions f era = Transactions 24 | { estimateTxFee :: Set.Set Sdk.FullCollateralTxIn -> Sdk.TxCandidate -> f C.Lovelace 25 | , finalizeTx :: Sdk.TxCandidate -> f (C.Tx era) 26 | , submitTx :: C.Tx era -> f C.TxId 27 | } 28 | 29 | mkTransactions 30 | :: (MonadThrow f, MonadIO f) 31 | => CardanoNetwork f C.BabbageEra 32 | -> C.NetworkId 33 | -> Map P.Script C.TxIn 34 | -> WalletOutputs f 35 | -> Vault f 36 | -> TxAssemblyConfig 37 | -> Transactions f C.BabbageEra 38 | mkTransactions network networkId refScriptsMap utxos wallet conf = Transactions 39 | { estimateTxFee = estimateTxFee' network networkId refScriptsMap 40 | , finalizeTx = finalizeTx' network networkId refScriptsMap utxos wallet conf 41 | , submitTx = submitTx' network 42 | } 43 | 44 | estimateTxFee' 45 | :: MonadThrow f 46 | => MonadIO f 47 | => CardanoNetwork f C.BabbageEra 48 | -> C.NetworkId 49 | -> Map P.Script C.TxIn 50 | -> Set.Set Sdk.FullCollateralTxIn 51 | -> Sdk.TxCandidate 52 | -> f C.Lovelace 53 | estimateTxFee' CardanoNetwork{..} network refScriptsMap collateral txc = do 54 | SystemEnv{pparams} <- getSystemEnv 55 | Internal.estimateTxFee pparams network refScriptsMap collateral txc 56 | 57 | finalizeTx' 58 | :: MonadThrow f 59 | => CardanoNetwork f C.BabbageEra 60 | -> C.NetworkId 61 | -> Map P.Script C.TxIn 62 | -> WalletOutputs f 63 | -> Vault f 64 | -> TxAssemblyConfig 65 | -> Sdk.TxCandidate 66 | -> f (C.Tx C.BabbageEra) 67 | finalizeTx' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAssemblyConfig{..} txc@Sdk.TxCandidate{..} = do 68 | sysenv <- getSystemEnv 69 | collaterals <- selectCollaterals utxos sysenv refScriptsMap network conf txc 70 | 71 | (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTx sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc 72 | let 73 | allInputs = (Set.elems txCandidateInputs <&> Sdk.fullTxInTxOut) ++ (Set.elems collaterals <&> Sdk.fullCollateralTxInTxOut) 74 | signatories = allInputs >>= getPkh 75 | where 76 | getPkh Sdk.FullTxOut{fullTxOutAddress=P.Address (P.PubKeyCredential pkh) _} = [pkh] 77 | getPkh _ = [] 78 | signers <- mapM (\pkh -> getSigningKey pkh >>= maybe (throwM $ SignerNotFound pkh) pure) signatories 79 | pure $ Internal.signTx txb signers 80 | 81 | submitTx' :: Monad f => CardanoNetwork f C.BabbageEra -> C.Tx C.BabbageEra -> f C.TxId 82 | submitTx' CardanoNetwork{submitTx} tx = do 83 | submitTx tx 84 | pure . C.getTxId . C.getTxBody $ tx 85 | 86 | selectCollaterals 87 | :: MonadThrow f 88 | => WalletOutputs f 89 | -> SystemEnv 90 | -> Map P.Script C.TxIn 91 | -> C.NetworkId 92 | -> TxAssemblyConfig 93 | -> Sdk.TxCandidate 94 | -> f (Set.Set Sdk.FullCollateralTxIn) 95 | selectCollaterals WalletOutputs{selectUtxosStrict} SystemEnv{..} refScriptsMap network TxAssemblyConfig{..} txc@Sdk.TxCandidate{..} = do 96 | let isScriptIn Sdk.FullTxIn{fullTxInType=P.ConsumeScriptAddress {}} = True 97 | isScriptIn _ = False 98 | 99 | scriptInputs = filter isScriptIn (Set.elems txCandidateInputs) 100 | 101 | collectCollaterals knownCollaterals = do 102 | let 103 | estimateCollateral' collaterals = do 104 | fee <- Internal.estimateTxFee pparams network refScriptsMap collaterals txc 105 | let (C.Quantity fee') = C.lovelaceToQuantity fee 106 | collateralPercent = naturalToInteger $ fromMaybe 0 (C.protocolParamCollateralPercent pparams) 107 | pure $ P.Lovelace $ collateralPercent * fee' `div` 100 108 | 109 | collateral <- estimateCollateral' knownCollaterals 110 | utxos <- selectUtxosStrict (P.toValue collateral) >>= maybe (throwM FailedToSatisfyCollateral) pure 111 | 112 | let collaterals = Set.fromList $ Set.elems utxos <&> Sdk.FullCollateralTxIn 113 | 114 | collateral' <- estimateCollateral' collaterals 115 | 116 | if collateral' > collateral 117 | then collectCollaterals collaterals 118 | else pure collaterals 119 | 120 | case (scriptInputs, collateralPolicy) of 121 | ([], _) -> pure mempty 122 | (_, Cover) -> collectCollaterals mempty 123 | _ -> throwM CollateralNotAllowed 124 | -------------------------------------------------------------------------------- /submit-api/submit-api.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: submit-api 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: ErgoLabs 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | BangPatterns 23 | BinaryLiterals 24 | ConstraintKinds 25 | DataKinds 26 | DefaultSignatures 27 | DeriveDataTypeable 28 | DeriveFoldable 29 | DeriveFunctor 30 | DeriveGeneric 31 | DeriveTraversable 32 | DoAndIfThenElse 33 | EmptyDataDecls 34 | ExistentialQuantification 35 | FlexibleContexts 36 | FlexibleInstances 37 | FunctionalDependencies 38 | GADTs 39 | GeneralizedNewtypeDeriving 40 | InstanceSigs 41 | KindSignatures 42 | LambdaCase 43 | MultiParamTypeClasses 44 | MultiWayIf 45 | NamedFieldPuns 46 | PartialTypeSignatures 47 | PatternGuards 48 | PolyKinds 49 | RankNTypes 50 | RecordWildCards 51 | ScopedTypeVariables 52 | StandaloneDeriving 53 | TupleSections 54 | TypeFamilies 55 | TypeSynonymInstances 56 | ViewPatterns 57 | 58 | ghc-options: -Wall 59 | -Wcompat 60 | -Wincomplete-record-updates 61 | -Wincomplete-uni-patterns 62 | -Wpartial-fields 63 | -Wredundant-constraints 64 | -Wunused-packages 65 | -Widentities 66 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 67 | 68 | library 69 | import: base, project-config 70 | 71 | hs-source-dirs: src 72 | 73 | exposed-modules: SubmitAPI.Service 74 | SubmitAPI.Config 75 | SubmitAPI.Internal.Transaction 76 | SubmitAPI.Internal.Balancing 77 | 78 | build-depends: 79 | rio, 80 | serialise, 81 | cardano-tx, 82 | network-api, 83 | wallet-api, 84 | plutus-chain-index, 85 | plutus-tx, 86 | plutus-ledger-api, 87 | plutus-ledger-constraints, 88 | plutus-contract, 89 | prettyprinter, 90 | cardano-slotting, 91 | cardano-api, 92 | mtl, 93 | plutus-ledger, 94 | bytestring, 95 | aeson, 96 | servant, 97 | singletons, 98 | either, 99 | aeson-gadt-th, 100 | plutus-script-utils, 101 | some, 102 | dependent-sum-template, 103 | containers, 104 | freer-simple, 105 | extra, 106 | text, 107 | dhall, 108 | plutus-contract, 109 | freer-simple, 110 | cardano-ledger-alonzo, 111 | cardano-ledger-shelley, 112 | cardano-ledger-core, 113 | cardano-ledger-shelley-ma, 114 | cardano-ledger-byron, 115 | cardano-ledger-babbage, 116 | ouroboros-consensus, 117 | microlens, 118 | cardano-binary, 119 | strict-containers, 120 | transformers, 121 | array 122 | -- free-er==0.1.0.0 123 | 124 | test-suite submit-api-tests 125 | type: exitcode-stdio-1.0 126 | main-is: Main.hs 127 | hs-source-dirs: test 128 | other-modules: 129 | Gen.CardanoTx 130 | Spec.Network 131 | Spec.Transaction 132 | build-depends: 133 | , base 134 | , HUnit 135 | , hedgehog 136 | , tasty 137 | , tasty-hunit 138 | , tasty-hedgehog 139 | , aeson 140 | , text 141 | , base16-bytestring 142 | , bytestring 143 | , plutus-ledger-api 144 | , cardano-api 145 | , ouroboros-consensus 146 | , random 147 | , plutus-tx 148 | , plutus-ledger-api 149 | , plutus-script-utils 150 | , plutus-ledger 151 | , containers 152 | , random-strings 153 | , plutus-core 154 | , cardano-ledger-shelley 155 | , cardano-ledger-babbage 156 | , submit-api 157 | , cardano-tx 158 | , network-api 159 | , wallet-api 160 | , serialise 161 | , cardano-dex-contracts-offchain 162 | , cardano-ledger-alonzo 163 | -------------------------------------------------------------------------------- /submit-api/test/Gen/CardanoTx.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Gen.CardanoTx where 4 | 5 | import Data.Functor ((<&>)) 6 | import qualified Data.ByteString as BS 7 | import Data.Map as Map 8 | import Data.Set as Set 9 | 10 | import Hedgehog 11 | import Hedgehog.Gen as Gen 12 | import Hedgehog.Range as Range 13 | 14 | import qualified Ledger.Ada as Ada 15 | import qualified Ledger as P 16 | import qualified Ledger.Value as P 17 | import qualified Ledger.Value as Value 18 | import qualified PlutusTx.Builtins.Internal as P 19 | import qualified Plutus.Script.Utils.Scripts as P 20 | import qualified Plutus.V1.Ledger.Api as P 21 | import qualified Ledger.Interval as Interval 22 | import Ledger.Ada (adaValueOf) 23 | import qualified PlutusTx 24 | 25 | import qualified CardanoTx.Models as Sdk 26 | import CardanoTx.Models (TxOutDatum(EmptyDatum)) 27 | 28 | mkTokenName :: BS.ByteString -> P.TokenName 29 | mkTokenName = P.TokenName . P.BuiltinByteString 30 | 31 | mkCurrencySymbol :: BS.ByteString -> P.CurrencySymbol 32 | mkCurrencySymbol = P.CurrencySymbol . P.BuiltinByteString 33 | 34 | mkAssetClass :: BS.ByteString -> BS.ByteString -> P.AssetClass 35 | mkAssetClass cs tn = P.AssetClass (mkCurrencySymbol cs, mkTokenName tn) 36 | 37 | mkValue :: P.AssetClass -> Integer -> P.Value 38 | mkValue (P.AssetClass (cs, tn)) = Value.singleton cs tn 39 | 40 | mkAdaValue :: Integer -> P.Value 41 | mkAdaValue = mkValue (P.AssetClass (Ada.adaSymbol, Ada.adaToken)) 42 | 43 | genAdaValue :: MonadGen f => f P.Value 44 | genAdaValue = integral (Range.constant (10^8) (10^12)) <&> mkAdaValue 45 | 46 | genBuiltinByteString :: MonadGen f => Int -> f P.BuiltinByteString 47 | genBuiltinByteString s = bytes (Range.singleton s) <&> P.BuiltinByteString 48 | 49 | genTxId :: MonadGen f => f P.TxId 50 | genTxId = prune $ genBuiltinByteString 32 <&> P.TxId 51 | 52 | genTxOutRef :: MonadGen f => f P.TxOutRef 53 | genTxOutRef = do 54 | txId <- genTxId 55 | ix <- integral $ Range.constant 0 10 56 | pure $ P.TxOutRef txId ix 57 | 58 | genPkh :: MonadGen f => f P.PubKeyHash 59 | genPkh = genBuiltinByteString 28 <&> P.PubKeyHash 60 | 61 | genPkhAddress :: MonadGen f => f P.Address 62 | genPkhAddress = genPkh <&> (\pkh -> P.pubKeyHashAddress (P.PaymentPubKeyHash pkh) Nothing) 63 | 64 | stablePkh :: P.PubKeyHash 65 | stablePkh = "d74d26c5029cf290094fce1a0670da7369b9026571dfb977c6fa234f" 66 | 67 | stableAddress :: P.Address 68 | stableAddress = P.pubKeyHashAddress (P.PaymentPubKeyHash stablePkh) Nothing 69 | 70 | data DummyDatum = DummyDatum Integer Bool 71 | instance P.ToData DummyDatum where 72 | {-# INLINE toBuiltinData #-} 73 | toBuiltinData a = P.mkConstr 0 (P.mkCons (P.mkI 99) (P.mkCons (P.toBuiltinData True) (P.BuiltinList []))) 74 | 75 | genNonEmptyDatum :: MonadGen f => f (P.Datum, P.DatumHash) 76 | genNonEmptyDatum = Gen.constant (d, P.datumHash d) 77 | where d = P.Datum $ P.toBuiltinData $ DummyDatum 1 True 78 | 79 | genFullTxOut :: MonadGen f => f Sdk.FullTxOut 80 | genFullTxOut = do 81 | value <- genAdaValue 82 | genFullTxOutExact value 83 | 84 | genFullTxOutExact :: MonadGen f => P.Value -> f Sdk.FullTxOut 85 | genFullTxOutExact value = do 86 | ref <- genTxOutRef 87 | addr <- genPkhAddress 88 | pure $ Sdk.FullTxOut ref addr value EmptyDatum Nothing 89 | 90 | genFullTxIn :: MonadGen f => f Sdk.FullTxIn 91 | genFullTxIn = genFullTxOut <&> (`Sdk.FullTxIn` P.ConsumePublicKeyAddress) 92 | 93 | genFullScriptTxIn :: MonadGen f => f Sdk.FullTxIn 94 | genFullScriptTxIn = undefined 95 | 96 | genFullTxInExact :: MonadGen f => P.Value -> f Sdk.FullTxIn 97 | genFullTxInExact value = genFullTxOutExact value <&> (`Sdk.FullTxIn` P.ConsumePublicKeyAddress) 98 | 99 | genTxOutCandidate :: MonadGen f => f Sdk.TxOutCandidate 100 | genTxOutCandidate = do 101 | value <- genAdaValue 102 | genTxOutCandidateExact value 103 | 104 | genTxOutCandidateExact :: MonadGen f => P.Value -> f Sdk.TxOutCandidate 105 | genTxOutCandidateExact value = do 106 | addr <- genPkhAddress 107 | pure $ Sdk.TxOutCandidate addr value EmptyDatum Nothing 108 | 109 | genPlainTxCandidate :: MonadGen f => f Sdk.TxCandidate 110 | genPlainTxCandidate = do 111 | inputs <- Gen.set (Range.constant 3 10) genFullTxIn <&> Set.elems 112 | outputs <- Gen.set (Range.constant 3 10) genTxOutCandidate <&> Set.elems 113 | let 114 | adaIn = Prelude.foldl (\ acc i -> acc + (Ada.getLovelace $ Ada.fromValue $ Sdk.fullTxOutValue $ Sdk.fullTxInTxOut i)) 0 inputs 115 | adaOut = Prelude.foldl (\ acc i -> acc + (Ada.getLovelace $ Ada.fromValue $ Sdk.txOutCandidateValue i)) 0 outputs 116 | txFee = 10^10 117 | delta = adaOut + txFee - adaIn 118 | extraIn <- if delta > 0 119 | then genFullTxInExact (Ada.lovelaceValueOf delta) <&> pure 120 | else pure [] 121 | let updatedInputs = Set.fromList $ inputs ++ extraIn 122 | pure $ Sdk.TxCandidate updatedInputs [] outputs mempty mempty Nothing Interval.always mempty 123 | -------------------------------------------------------------------------------- /submit-api/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Text.Encoding as E 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | 8 | import Spec.Transaction 9 | import System.Exit (exitFailure) 10 | import Control.Monad (unless) 11 | 12 | main :: IO () 13 | main = defaultMain tests 14 | 15 | tests = testGroup "SubmitApi" 16 | [ buildTxBodyTests 17 | , buildTxBodyContentTests 18 | , buildBalancedTxTests 19 | ] -------------------------------------------------------------------------------- /submit-api/test/Spec/Transaction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Spec.Transaction where 4 | 5 | import Data.Functor ((<&>)) 6 | import qualified Data.ByteString as BS 7 | import Data.Map as Map 8 | import qualified Data.List as List 9 | import Data.Set as Set 10 | 11 | import Hedgehog 12 | import Hedgehog.Gen as Gen 13 | import Hedgehog.Range as Range 14 | import Test.Tasty (testGroup) 15 | import Test.Tasty.Hedgehog as HH 16 | 17 | import Gen.CardanoTx 18 | import Spec.Network 19 | 20 | import qualified Cardano.Api as C 21 | 22 | import NetworkAPI.Types 23 | import SubmitAPI.Internal.Transaction 24 | import CardanoTx.Models 25 | import CardanoTx.Interop as Interop 26 | import Cardano.Api.Shelley (NetworkId(Mainnet)) 27 | 28 | inputsOrderPreservedBuildTxBody :: Property 29 | inputsOrderPreservedBuildTxBody = property $ do 30 | txc <- forAll genPlainTxCandidate 31 | ctx <- buildTxBodyContent staticProtocolParams Mainnet mempty mempty txc 32 | let 33 | Right txb = C.makeTransactionBody ctx 34 | candidateInputs = Set.elems (txCandidateInputs txc) <&> (fullTxOutRef . fullTxInTxOut) 35 | balancedInputs = Interop.extractCardanoTxBodyInputs txb 36 | balancedInputs === candidateInputs 37 | 38 | outputsOrderPreservedBuildTxBody :: Property 39 | outputsOrderPreservedBuildTxBody = property $ do 40 | txc <- forAll genPlainTxCandidate 41 | ctx <- buildTxBodyContent staticProtocolParams Mainnet mempty mempty txc 42 | let 43 | Right txb = C.makeTransactionBody ctx 44 | candidateOutputs = zip [0..] $ txCandidateOutputs txc 45 | balancedOutputs = Interop.extractCardanoTxBodyOutputs txb 46 | balancedOutputs === candidateOutputs 47 | 48 | buildTxBodyTests = testGroup "BuildTxBody" 49 | [ HH.testProperty "inputs_order_preserved" inputsOrderPreservedBuildTxBody 50 | , HH.testProperty "outputs_order_preserved" outputsOrderPreservedBuildTxBody 51 | ] 52 | 53 | inputsOrderPreservedContent :: Property 54 | inputsOrderPreservedContent = property $ do 55 | txc <- forAll genPlainTxCandidate 56 | ctx <- buildTxBodyContent staticProtocolParams Mainnet mempty mempty txc 57 | let 58 | candidateInputs = Set.elems (txCandidateInputs txc) <&> (fullTxOutRef . fullTxInTxOut) 59 | balancedInputs = Interop.extractCardanoTxContentInputs ctx 60 | balancedInputs === candidateInputs 61 | 62 | outputsOrderPreservedContent :: Property 63 | outputsOrderPreservedContent = property $ do 64 | txc <- forAll genPlainTxCandidate 65 | ctx <- buildTxBodyContent staticProtocolParams Mainnet mempty mempty txc 66 | let 67 | candidateOutputs = zip [0..] $ txCandidateOutputs txc 68 | balancedOutputs = Interop.extractCardanoTxContentOutputs ctx 69 | balancedOutputs === candidateOutputs 70 | 71 | buildTxBodyContentTests = testGroup "BuildTxBodyContent" 72 | [ HH.testProperty "inputs_order_preserved" inputsOrderPreservedContent 73 | , HH.testProperty "outputs_order_preserved" outputsOrderPreservedContent 74 | ] 75 | 76 | inputsOrderPreservedBalancing :: Property 77 | inputsOrderPreservedBalancing = property $ do 78 | txc <- forAll genPlainTxCandidate 79 | (C.BalancedTxBody txb _ _) <- buildBalancedTx staticSystemEnv mempty Mainnet (ChangeAddress stableAddress) mempty txc 80 | let 81 | candidateInputs = Set.elems (txCandidateInputs txc) <&> (fullTxOutRef . fullTxInTxOut) 82 | balancedInputs = Interop.extractCardanoTxBodyInputs txb 83 | balancedInputs === candidateInputs 84 | 85 | outputsOrderPreservedBalancing :: Property 86 | outputsOrderPreservedBalancing = property $ do 87 | txc <- forAll genPlainTxCandidate 88 | (C.BalancedTxBody txb _ _) <- buildBalancedTx staticSystemEnv mempty Mainnet (ChangeAddress stableAddress) mempty txc 89 | let 90 | candidateOutputs = zip [0..] $ txCandidateOutputs txc 91 | balancedOutputs = Interop.extractCardanoTxBodyOutputs txb 92 | List.init balancedOutputs === candidateOutputs 93 | 94 | buildBalancedTxTests = testGroup "BuildBalancedTx" 95 | [ HH.testProperty "inputs_order_preserved" inputsOrderPreservedBalancing 96 | , HH.testProperty "outputs_order_preserved" outputsOrderPreservedBalancing 97 | ] 98 | -------------------------------------------------------------------------------- /wallet-api/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /wallet-api/src/WalletAPI/Internal/Crypto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE GADTs #-} 4 | 5 | module WalletAPI.Internal.Crypto where 6 | 7 | import Crypto.Cipher.Types (BlockCipher(..), Cipher(..), IV, makeIV) 8 | import Crypto.Error (CryptoFailable(..), CryptoError(..)) 9 | 10 | import qualified Crypto.Random.Types as CRT 11 | 12 | import Data.ByteArray (ByteArray) 13 | import Data.ByteString (ByteString) 14 | import qualified Data.ByteString.Base16 as Hex 15 | import Data.Aeson hiding (Key(..)) 16 | import qualified Data.Text.Encoding as T 17 | 18 | data Key c a where 19 | Key :: (BlockCipher c, ByteArray a) => a -> Key c a 20 | 21 | newtype Salt = Salt { unSalt :: ByteString } 22 | 23 | instance ToJSON Salt where 24 | toJSON = toJSON . T.decodeUtf8 . Hex.encode . unSalt 25 | 26 | instance FromJSON Salt where 27 | parseJSON (String s) = either fail (pure . Salt) (Hex.decode . T.encodeUtf8 $ s) 28 | parseJSON _ = fail "Expected a string" 29 | 30 | newtype Ciphertext = Ciphertext { unCyphertext :: ByteString } 31 | 32 | instance ToJSON Ciphertext where 33 | toJSON = toJSON . T.decodeUtf8 . Hex.encode . unCyphertext 34 | 35 | instance FromJSON Ciphertext where 36 | parseJSON (String s) = either fail (pure . Ciphertext) (Hex.decode . T.encodeUtf8 $ s) 37 | parseJSON _ = fail "Expected a string" 38 | 39 | newtype EncodedVK = EncodedVK { unEncodedVK :: ByteString } 40 | 41 | instance ToJSON EncodedVK where 42 | toJSON = toJSON . T.decodeUtf8 . Hex.encode . unEncodedVK 43 | 44 | instance FromJSON EncodedVK where 45 | parseJSON (String s) = either fail (pure . EncodedVK) (Hex.decode . T.encodeUtf8 $ s) 46 | parseJSON _ = fail "Expected a string" 47 | 48 | newtype EncodedIV = EncodedIV { unEncodedIV :: ByteString } 49 | 50 | instance ToJSON EncodedIV where 51 | toJSON = toJSON . T.decodeUtf8 . Hex.encode . unEncodedIV 52 | 53 | instance FromJSON EncodedIV where 54 | parseJSON (String s) = either fail (pure . EncodedIV) (Hex.decode . T.encodeUtf8 $ s) 55 | parseJSON _ = fail "Expected a string" 56 | 57 | -- | Generate a random initialization vector for a given block cipher 58 | genRandomIV :: forall f c. (CRT.MonadRandom f, BlockCipher c) => f (Maybe (IV c)) 59 | genRandomIV = do 60 | bytes :: ByteString <- CRT.getRandomBytes $ blockSize (undefined :: c) 61 | pure $ makeIV bytes 62 | 63 | -- | Generate random salt of a given size 64 | genRandomSalt :: forall f. (CRT.MonadRandom f) => Int -> f Salt 65 | genRandomSalt = fmap Salt . CRT.getRandomBytes 66 | 67 | -- | Initialize a block cipher 68 | initCipher :: (BlockCipher c, ByteArray a) => Key c a -> Either CryptoError c 69 | initCipher (Key k) = case cipherInit k of 70 | CryptoFailed e -> Left e 71 | CryptoPassed a -> Right a 72 | 73 | encrypt :: (BlockCipher c, ByteArray a) => Key c a -> IV c -> a -> Either CryptoError a 74 | encrypt secretKey initIV msg = 75 | case initCipher secretKey of 76 | Left e -> Left e 77 | Right c -> Right $ ctrCombine c initIV msg 78 | 79 | decrypt :: (BlockCipher c, ByteArray a) => Key c a -> IV c -> a -> Either CryptoError a 80 | decrypt = encrypt 81 | -------------------------------------------------------------------------------- /wallet-api/src/WalletAPI/Internal/Models.hs: -------------------------------------------------------------------------------- 1 | module WalletAPI.Internal.Models where 2 | 3 | import RIO 4 | import Data.Aeson 5 | 6 | import WalletAPI.Internal.Crypto 7 | 8 | data TrustStoreFile = TrustStoreFile 9 | { trustStoreSecret :: SecretEnvelope 10 | , trustStoreVK :: EncodedVK 11 | } deriving (Generic, ToJSON, FromJSON) 12 | 13 | data SecretEnvelope = SecretEnvelope 14 | { secretCiphertext :: Ciphertext 15 | , secretSalt :: Salt 16 | , secretIv :: EncodedIV 17 | } deriving (Generic, ToJSON, FromJSON) 18 | -------------------------------------------------------------------------------- /wallet-api/src/WalletAPI/UtxoStore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module WalletAPI.UtxoStore where 3 | 4 | import RIO 5 | import qualified Data.Set as Set 6 | import qualified Data.Map as Map 7 | import qualified Database.RocksDB as Rocks 8 | import Control.Monad.Trans.Resource 9 | ( MonadResource ) 10 | 11 | import Ledger 12 | import System.Logging.Hlog 13 | import CardanoTx.Models ( FullTxOut(..) ) 14 | import WalletAPI.UtxoStoreConfig 15 | import Data.Aeson (FromJSON) 16 | import Spectrum.Common.Persistence.Serialization 17 | ( serialize, deserializeM ) 18 | import Data.Conduit 19 | 20 | type Store = Map.Map TxOutRef FullTxOut 21 | 22 | data UtxoStore f = UtxoStore 23 | { putUtxos :: Set.Set FullTxOut -> f () 24 | , getUtxos :: f (Set.Set FullTxOut) 25 | , dropUtxos :: Set.Set TxOutRef -> f () 26 | , containsUtxo :: TxOutRef -> f Bool 27 | } 28 | 29 | mkPersistentUtxoStoreWithCache :: forall i f. (MonadIO i, MonadResource i, MonadIO f, MonadThrow f) => MakeLogging i f -> UtxoStoreConfig -> i (UtxoStore f) 30 | mkPersistentUtxoStoreWithCache MakeLogging{.. } UtxoStoreConfig{..} = do 31 | logging <- forComponent "PersistentUtxoStore" 32 | storeT <- liftIO $ newTVarIO mempty 33 | (_, db) <- Rocks.openBracket utxoStorePath 34 | Rocks.defaultOptions 35 | { Rocks.createIfMissing = createIfMissing 36 | } 37 | let 38 | get :: FromJSON a => ByteString -> f (Maybe a) 39 | get = (=<<) (mapM deserializeM) . Rocks.get db Rocks.defaultReadOptions 40 | put = Rocks.put db Rocks.defaultWriteOptions :: ByteString -> ByteString -> f () 41 | delete = Rocks.delete db Rocks.defaultWriteOptions :: ByteString -> f () 42 | pure $ attachTracing logging UtxoStore 43 | { putUtxos = \utxos -> 44 | ((\output@FullTxOut{fullTxOutRef} -> put (mkKey fullTxOutRef) (serialize output)) `traverse` toList utxos) >> put' storeT utxos 45 | , getUtxos = do 46 | inCache <- get' storeT 47 | if null inCache 48 | then Rocks.range db Nothing Nothing >>= (\case 49 | (Just utxoStream) -> do 50 | rawUtxosList <- liftIO . sourceToList $ mapOutputMaybe id utxoStream 51 | parsedUtxos <- (\(_, rawUtxo) -> deserializeM rawUtxo) `traverse` rawUtxosList 52 | pure $ Set.fromList parsedUtxos 53 | Nothing -> pure Set.empty 54 | ) 55 | else pure inCache 56 | , dropUtxos = \refs -> 57 | (delete . mkKey) `traverse` toList refs >> drop' storeT refs 58 | , containsUtxo = \ref -> 59 | (get (mkKey ref) :: f (Maybe FullTxOut)) <&> isJust 60 | } 61 | 62 | mkUtxoStore :: (MonadIO i, MonadIO f) => MakeLogging i f -> i (UtxoStore f) 63 | mkUtxoStore MakeLogging{..} = do 64 | logging <- forComponent "UtxoStore" 65 | storeT <- liftIO $ newTVarIO mempty 66 | pure $ attachTracing logging UtxoStore 67 | { putUtxos = put' storeT 68 | , getUtxos = get' storeT 69 | , dropUtxos = drop' storeT 70 | , containsUtxo = contains' storeT 71 | } 72 | 73 | put' :: MonadIO f => TVar Store -> Set.Set FullTxOut -> f () 74 | put' storeT outs = 75 | liftIO $ atomically $ do 76 | store <- readTVar storeT 77 | let store' = Map.union store (Map.fromList $ Set.elems outs <&> (\o -> (fullTxOutRef o, o))) 78 | writeTVar storeT store' 79 | 80 | get' :: MonadIO f => TVar Store -> f (Set.Set FullTxOut) 81 | get' storeT = liftIO $ atomically $ readTVar storeT <&> Set.fromList . Map.elems 82 | 83 | drop' :: MonadIO f => TVar Store -> Set.Set TxOutRef -> f () 84 | drop' storeT orefs = 85 | liftIO $ atomically $ do 86 | store <- readTVar storeT 87 | let store' = foldr Map.delete store orefs 88 | writeTVar storeT store' 89 | 90 | contains' :: MonadIO f => TVar Store -> TxOutRef -> f Bool 91 | contains' storeT ref = liftIO $ atomically $ readTVar storeT <&> Map.member ref 92 | 93 | mkKey :: TxOutRef -> ByteString 94 | mkKey = fromString . show 95 | 96 | attachTracing :: Monad f => Logging f -> UtxoStore f -> UtxoStore f 97 | attachTracing Logging{..} UtxoStore{..} = 98 | UtxoStore 99 | { putUtxos = \utxos -> do 100 | debugM $ "putUtxos " <> show utxos 101 | r <- putUtxos utxos 102 | debugM $ "putUtxos -> " <> show r 103 | pure r 104 | , getUtxos = do 105 | debugM @String "getUtxos" 106 | r <- getUtxos 107 | debugM $ "getUtxos -> " <> show r 108 | pure r 109 | , dropUtxos = \outRefs -> do 110 | debugM $ "dropUtxos " <> show outRefs 111 | r <- dropUtxos outRefs 112 | debugM $ "dropUtxos -> " <> show r 113 | pure r 114 | , containsUtxo = \ref -> do 115 | debugM $ "containsUtxo " <> show ref 116 | r <- containsUtxo ref 117 | debugM $ "containsUtxo -> " <> show r 118 | pure r 119 | } 120 | -------------------------------------------------------------------------------- /wallet-api/src/WalletAPI/UtxoStoreConfig.hs: -------------------------------------------------------------------------------- 1 | module WalletAPI.UtxoStoreConfig 2 | ( UtxoStoreConfig(..) 3 | ) where 4 | 5 | import GHC.Generics 6 | ( Generic ) 7 | import Dhall 8 | ( FromDhall ) 9 | 10 | data UtxoStoreConfig = UtxoStoreConfig 11 | { utxoStorePath :: FilePath 12 | , createIfMissing :: Bool 13 | } deriving (Generic, FromDhall) -------------------------------------------------------------------------------- /wallet-api/src/WalletAPI/Utxos.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | module WalletAPI.Utxos 3 | ( WalletOutputs(..) 4 | , mkWalletOutputs 5 | , mkWalletOutputs' 6 | , mkPersistentWalletOutputs 7 | ) where 8 | 9 | import RIO 10 | import qualified Data.Set as Set 11 | import Data.ByteArray.Encoding (Base(..), convertToBase) 12 | import qualified Data.Text.Encoding as T 13 | import Control.Retry 14 | import Control.Monad.Catch 15 | 16 | import Ledger 17 | import Plutus.V1.Ledger.Value 18 | import Cardano.Api hiding (Value) 19 | 20 | import CardanoTx.Models 21 | import WalletAPI.UtxoStore 22 | import WalletAPI.Vault 23 | import System.Logging.Hlog 24 | 25 | import Explorer.Service 26 | import qualified Explorer.Types as Explorer 27 | import qualified Explorer.Models as Explorer 28 | import qualified Explorer.Class as Explorer 29 | import Explorer.Types (PaymentCred) 30 | import Explorer.Models (Paging, Items) 31 | 32 | import Algebra.Natural 33 | import WalletAPI.UtxoStoreConfig (UtxoStoreConfig(..)) 34 | import Control.Monad.Trans.Resource (MonadResource) 35 | import Spectrum.Prelude.HigherKind (LiftK(..)) 36 | 37 | data WalletOutputs f = WalletOutputs 38 | -- Select UTxOs satisfying the given minumal Value. 39 | { selectUtxos :: Value -> f (Maybe (Set.Set FullTxOut)) 40 | -- Assets other than present in the given minimal Value are not allowed. 41 | , selectUtxosStrict :: Value -> f (Maybe (Set.Set FullTxOut)) 42 | } 43 | 44 | mkPersistentWalletOutputs :: 45 | ( MonadIO i 46 | , MonadIO f 47 | , MonadMask f 48 | , MonadResource i 49 | ) => (f ~> i) -> MakeLogging i f -> UtxoStoreConfig -> Explorer f -> Vault f -> i (WalletOutputs f) 50 | mkPersistentWalletOutputs fToI mkLogging@MakeLogging{..} cfg explorer vaultF = do 51 | let Vault{..} = fmapK fToI vaultF 52 | logging <- forComponent "WalletOutputs" 53 | ustore <- mkPersistentUtxoStoreWithCache mkLogging cfg 54 | pkh <- getPaymentKeyHash 55 | fToI $ filterSpentedUtxos ustore explorer 56 | pure $ WalletOutputs 57 | { selectUtxos = selectUtxos'' logging explorer ustore pkh False 58 | , selectUtxosStrict = selectUtxos'' logging explorer ustore pkh True 59 | } 60 | 61 | filterSpentedUtxos :: (Monad f) => UtxoStore f -> Explorer f -> f () 62 | filterSpentedUtxos UtxoStore{..} Explorer{..} = do 63 | allUtxos <- getUtxos 64 | (\FullTxOut{..} -> getOutput fullTxOutRef >>= (\case 65 | Just _ -> pure () 66 | Nothing -> dropUtxos $ Set.fromList [fullTxOutRef] 67 | )) `traverse` toList allUtxos 68 | pure () 69 | 70 | mkWalletOutputs :: (MonadIO i, MonadIO f, MonadMask f) => MakeLogging i f -> Explorer f -> Hash PaymentKey -> i (WalletOutputs f) 71 | mkWalletOutputs mkLogging@MakeLogging{..} explorer pkh = do 72 | logging <- forComponent "WalletOutputs" 73 | ustore <- mkUtxoStore mkLogging 74 | pure $ WalletOutputs 75 | { selectUtxos = selectUtxos'' logging explorer ustore pkh False 76 | , selectUtxosStrict = selectUtxos'' logging explorer ustore pkh True 77 | } 78 | 79 | mkWalletOutputs' :: forall i f. (MonadIO i, MonadIO f, MonadMask f) => (f ~> i) -> MakeLogging i f -> Explorer f -> Vault f -> i (WalletOutputs f) 80 | mkWalletOutputs' fToI mklogging explorer vaultF = do 81 | let Vault{..} = fmapK fToI vaultF 82 | getPaymentKeyHash >>= mkWalletOutputs mklogging explorer 83 | 84 | selectUtxos'' :: (MonadIO f, MonadMask f) => Logging f -> Explorer f -> UtxoStore f -> Hash PaymentKey -> Bool -> Value -> f (Maybe (Set.Set FullTxOut)) 85 | selectUtxos'' logging explorer ustore@UtxoStore{..} pkh strict requiredValue = do 86 | let 87 | fetchUtxos offset limit = do 88 | let 89 | paging = Explorer.Paging offset limit 90 | mkPCred = Explorer.PaymentCred . T.decodeUtf8 . convertToBase Base16 . serialiseToRawBytes 91 | utxoBatch <- getUnspentOutputsByPCredWithRetry logging explorer (mkPCred pkh) paging 92 | putUtxos (Set.fromList $ Explorer.items utxoBatch <&> Explorer.toCardanoTx) 93 | let entriesLeft = Explorer.total utxoBatch - (offset + limit) 94 | 95 | if entriesLeft > 0 96 | then fetchUtxos (offset + limit) limit 97 | else pure () 98 | 99 | extractAssets v = Set.fromList (flattenValue v <&> (\(cs, tn, _) -> (cs, tn))) 100 | requiredAssets = extractAssets requiredValue 101 | 102 | collect :: [FullTxOut] -> Value -> [FullTxOut] -> Maybe [FullTxOut] 103 | collect acc valueAcc outs = 104 | case outs of 105 | fout@FullTxOut{..} : tl | valueAcc `lt` requiredValue -> 106 | if satisfies 107 | then collect (fout : acc) (fullTxOutValue <> valueAcc) tl 108 | else collect acc valueAcc tl -- current output doesn't contain the required asset at all, so skipping it 109 | where 110 | assets = extractAssets fullTxOutValue 111 | containsTargetAsset = not $ Set.null $ Set.intersection assets requiredAssets 112 | containsOtherAssets = not $ Set.null $ Set.difference assets requiredAssets 113 | satisfies = (containsTargetAsset && not strict) || (containsTargetAsset && not containsOtherAssets) 114 | [] | valueAcc `lt` requiredValue -> 115 | Nothing 116 | _ -> 117 | Just acc 118 | 119 | utxos <- getUtxos 120 | case collect [] mempty (Set.elems utxos) of 121 | Just outs -> pure $ Just $ Set.fromList outs 122 | Nothing -> fetchUtxos 0 batchSize >> selectUtxos'' logging explorer ustore pkh strict requiredValue 123 | where batchSize = 400 124 | 125 | getUnspentOutputsByPCredWithRetry :: (MonadIO f, MonadMask f) => Logging f -> Explorer f -> PaymentCred -> Paging -> f (Items Explorer.FullTxOut) 126 | getUnspentOutputsByPCredWithRetry Logging{..} Explorer{..} cred paging = do 127 | let backoff = constantDelay 1000000 128 | recoverAll backoff (\rs -> infoM ("RetryStatus for getUnspentOutputsByPCredWithRetry " ++ (show rs)) >> (getUnspentOutputsByPCred cred paging)) -------------------------------------------------------------------------------- /wallet-api/src/WalletAPI/Vault.hs: -------------------------------------------------------------------------------- 1 | module WalletAPI.Vault where 2 | 3 | import RIO 4 | 5 | import qualified PlutusTx.Prelude as PlutusTx 6 | import Ledger (PubKeyHash(..)) 7 | import qualified Cardano.Api as C 8 | import Cardano.Api.Shelley 9 | import Algebra.Natural 10 | 11 | import WalletAPI.TrustStore (TrustStore(TrustStore, readSK, readVK), KeyPass) 12 | 13 | data VaultError = VaultCorrupted 14 | deriving (Show, Exception) 15 | 16 | data Vault f = Vault 17 | { getSigningKey :: PubKeyHash -> f (Maybe ShelleyWitnessSigningKey) 18 | , getPaymentKeyHash :: f (Hash PaymentKey) -- todo: dont mix Cardano.Api with Ledger.Api 19 | } 20 | 21 | instance FunctorK Vault where 22 | fmapK xa alg = 23 | Vault 24 | { getSigningKey = xa . getSigningKey alg 25 | , getPaymentKeyHash = xa $ getPaymentKeyHash alg 26 | } 27 | 28 | mkVault :: MonadThrow f => TrustStore f PaymentKey -> KeyPass -> Vault f 29 | mkVault tstore pass = do 30 | Vault 31 | { getSigningKey = getSigningKey' tstore pass 32 | , getPaymentKeyHash = getPaymentKeyHash' tstore 33 | } 34 | 35 | getSigningKey' :: MonadThrow f => TrustStore f PaymentKey -> KeyPass -> PubKeyHash -> f (Maybe ShelleyWitnessSigningKey) 36 | getSigningKey' TrustStore{readSK} pass pkh = do 37 | sk <- readSK pass <&> WitnessPaymentKey 38 | let vk = extractVK (toShelleySigningKey sk) 39 | pkh' = PubKeyHash $ PlutusTx.toBuiltin $ C.serialiseToRawBytes $ C.verificationKeyHash vk 40 | unless (pkh == pkh') (throwM VaultCorrupted) 41 | pure sk <&> Just 42 | 43 | extractVK :: ShelleySigningKey -> VerificationKey PaymentKey 44 | extractVK (ShelleyNormalSigningKey sk) = 45 | getVerificationKey 46 | . PaymentSigningKey 47 | $ sk 48 | extractVK (ShelleyExtendedSigningKey sk) = 49 | (castVerificationKey :: VerificationKey PaymentExtendedKey -> VerificationKey PaymentKey) 50 | . getVerificationKey 51 | . PaymentExtendedSigningKey 52 | $ sk 53 | 54 | getPaymentKeyHash' :: Functor f => TrustStore f PaymentKey -> f (Hash PaymentKey) 55 | getPaymentKeyHash' TrustStore{readVK} = readVK <&> C.verificationKeyHash 56 | -------------------------------------------------------------------------------- /wallet-api/wallet-api.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: wallet-api 3 | version: 0.1.0.0 4 | 5 | author: ErgoLabs 6 | maintainer: ErgoLabs 7 | 8 | extra-source-files: CHANGELOG.md 9 | 10 | source-repository head 11 | type: git 12 | location: https://github.com/ergolabs/cardano-dex-sdk-haskell 13 | 14 | common base 15 | build-depends: base >= 4.9 && < 5 16 | 17 | common project-config 18 | default-language: Haskell2010 19 | 20 | default-extensions: OverloadedStrings 21 | DeriveAnyClass 22 | BangPatterns 23 | BinaryLiterals 24 | ConstraintKinds 25 | DataKinds 26 | DefaultSignatures 27 | DeriveDataTypeable 28 | DerivingStrategies 29 | DeriveFoldable 30 | DeriveFunctor 31 | DeriveGeneric 32 | DeriveTraversable 33 | DoAndIfThenElse 34 | EmptyDataDecls 35 | ExistentialQuantification 36 | FlexibleContexts 37 | FlexibleInstances 38 | FunctionalDependencies 39 | GADTs 40 | GeneralizedNewtypeDeriving 41 | InstanceSigs 42 | KindSignatures 43 | LambdaCase 44 | MultiParamTypeClasses 45 | MultiWayIf 46 | NamedFieldPuns 47 | PartialTypeSignatures 48 | PatternGuards 49 | PolyKinds 50 | RankNTypes 51 | RecordWildCards 52 | ScopedTypeVariables 53 | StandaloneDeriving 54 | TupleSections 55 | TypeFamilies 56 | TypeSynonymInstances 57 | TypeApplications 58 | ViewPatterns 59 | 60 | ghc-options: -Wall 61 | -Wcompat 62 | -Wincomplete-record-updates 63 | -Wincomplete-uni-patterns 64 | -Wpartial-fields 65 | -Wredundant-constraints 66 | -Wunused-packages 67 | -Widentities 68 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 69 | 70 | library 71 | import: base, project-config 72 | 73 | hs-source-dirs: src 74 | 75 | exposed-modules: WalletAPI.Vault 76 | WalletAPI.Utxos 77 | WalletAPI.TrustStore 78 | WalletAPI.UtxoStore 79 | WalletAPI.UtxoStoreConfig 80 | WalletAPI.Internal.Crypto 81 | WalletAPI.Internal.Models 82 | 83 | build-depends: rio 84 | , serialise 85 | , binary 86 | , cardano-tx 87 | , quickblue 88 | , plutus-tx 89 | , plutus-ledger-api 90 | , cardano-crypto-wrapper 91 | , cardano-crypto-class 92 | , plutus-chain-index 93 | , prettyprinter 94 | , cardano-slotting 95 | , cryptonite 96 | , base16-bytestring 97 | , mtl 98 | , plutus-ledger 99 | , memory 100 | , stm 101 | , bytestring 102 | , aeson 103 | , spectrum 104 | , servant 105 | , singletons 106 | , either 107 | , aeson-gadt-th 108 | , some 109 | , dependent-sum-template 110 | , containers 111 | , freer-simple 112 | , extra 113 | , cardano-api 114 | , text 115 | , dhall 116 | , retry 117 | , exceptions 118 | , hlog 119 | , algebra-core 120 | , rocksdb-haskell 121 | , resourcet 122 | , conduit --------------------------------------------------------------------------------