From 10ee63f9e06fb4e39288f00ecfc04511cc31a92f Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Thu, 5 Sep 2024 19:26:13 +0530 Subject: [PATCH 1/9] ci(#348): add fourmolu auto-commit to CI --- .github/workflows/haskell.yml | 16 ++++++++++++ fourmolu.yaml | 48 ++++++++++++++++++++++++++++++++--- 2 files changed, 60 insertions(+), 4 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 5d87eced..58256f8f 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -118,6 +118,22 @@ jobs: ${{ runner.os }}-build-${{ env.cache-name }}- ${{ runner.os }}-build- ${{ runner.os }}- + + - name: Install fourmolu + run: cabal install fourmolu --overwrite-policy=always + + - name: Lint Haskell + run: | + find . -name '*.hs' -exec sh -c 'for file do fourmolu -i "$file"; done' sh {} + + + - name: Auto-commit lint + uses: stefanzweifel/git-auto-commit-action@v4 + with: + commit_message: fourmolu auto-commit + commit_user_name: GitHub Action + commit_user_email: action@github.com + branch: ${{ github.head_ref }} + - name: Install LIBSODIUM run: | git clone https://github.com/input-output-hk/libsodium diff --git a/fourmolu.yaml b/fourmolu.yaml index c7f07713..16e19972 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1,7 +1,47 @@ +# Number of spaces per indentation step indentation: 2 -comma-style: leading + +# Max line length for automatic line breaking +column-limit: none + +# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) +function-arrows: leading + +# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) +comma-style: trailing + +# Styling of import/export lists (choices: leading, trailing, or diff-friendly) +import-export-style: diff-friendly + +# Whether to full-indent or half-indent 'where' bindings past the preceding body +indent-wheres: false + +# Whether to leave a space before an opening record brace record-brace-space: true -indent-wheres: true -respectful: true -haddock-style: multi-line + +# Number of spaces between top-level declarations newlines-between-decls: 1 + +# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) +haddock-style: multi-line + +# How to print module docstring +haddock-style-module: null + +# Styling of let blocks (choices: auto, inline, newline, or mixed) +let-style: auto + +# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) +in-style: right-align + +# Whether to put parentheses around a single constraint (choices: auto, always, or never) +single-constraint-parens: never + +# Output Unicode syntax (choices: detect, always, or never) +unicode: always + +# Give the programmer more choice on where to insert blank lines +respectful: false + +# Fixity information for operators +fixities: [] From 91e3a0f7aef86ad597252d8a1456f76633895e03 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Thu, 5 Sep 2024 19:28:57 +0530 Subject: [PATCH 2/9] ci(#348): update to write permission for auto-commit mechanism --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 58256f8f..839d49f0 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -18,7 +18,7 @@ on: value: ${{ jobs.build.outputs.ATLAS_VERSION }} permissions: - contents: read + contents: write jobs: build: From 965a15119ec029d1b97bf3548eee00f2b27fa949 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Thu, 5 Sep 2024 21:00:59 +0530 Subject: [PATCH 3/9] feat(#348): format files with fourmolu formatter --- .github/workflows/haskell.yml | 15 +- fourmolu.yaml | 48 +- .../GeniusYield/OnChain/AStakeValidator.hs | 20 +- .../OnChain/AStakeValidator/Compiled.hs | 24 +- .../OnChain/Examples/ReadOracle.hs | 23 +- .../OnChain/Examples/ReadOracle/Compiled.hs | 18 +- src-plutustx/GeniusYield/OnChain/TestToken.hs | 23 +- .../GeniusYield/OnChain/TestToken/Compiled.hs | 29 +- src/GeniusYield/Api/TestTokens.hs | 36 +- src/GeniusYield/CardanoApi/EraHistory.hs | 23 +- src/GeniusYield/CardanoApi/Query.hs | 46 +- src/GeniusYield/Examples/Common.hs | 11 +- src/GeniusYield/Examples/Gift.hs | 36 +- src/GeniusYield/Examples/Limbo.hs | 34 +- src/GeniusYield/Examples/Treat.hs | 43 +- src/GeniusYield/GYConfig.hs | 253 ++-- src/GeniusYield/HTTP/Errors.hs | 60 +- src/GeniusYield/Imports.hs | 152 +-- src/GeniusYield/Providers.hs | 19 +- src/GeniusYield/Providers/Blockfrost.hs | 797 ++++++------ src/GeniusYield/Providers/CachedQueryUTxOs.hs | 85 +- src/GeniusYield/Providers/Common.hs | 387 +++--- src/GeniusYield/Providers/GCP.hs | 75 +- src/GeniusYield/Providers/Kupo.hs | 245 ++-- src/GeniusYield/Providers/LiteChainIndex.hs | 223 ++-- src/GeniusYield/Providers/Maestro.hs | 480 ++++---- src/GeniusYield/Providers/Node.hs | 105 +- src/GeniusYield/Providers/Node/AwaitTx.hs | 57 +- src/GeniusYield/Providers/Node/Query.hs | 84 +- src/GeniusYield/Providers/Sentry.hs | 75 +- src/GeniusYield/ReadJSON.hs | 14 +- src/GeniusYield/Scripts/TestToken.hs | 26 +- src/GeniusYield/Test/Clb.hs | 935 +++++++------- src/GeniusYield/Test/FakeCoin.hs | 21 +- src/GeniusYield/Test/FeeTracker.hs | 297 ++--- src/GeniusYield/Test/Privnet/Asserts.hs | 79 +- src/GeniusYield/Test/Privnet/Ctx.hs | 241 ++-- src/GeniusYield/Test/Privnet/Examples.hs | 19 +- .../Test/Privnet/Examples/Common.hs | 8 +- src/GeniusYield/Test/Privnet/Examples/Gift.hs | 494 ++++---- src/GeniusYield/Test/Privnet/Examples/Misc.hs | 42 +- .../Test/Privnet/Examples/Oracle.hs | 125 +- .../Test/Privnet/Examples/Treat.hs | 112 +- src/GeniusYield/Test/Privnet/Setup.hs | 594 ++++----- src/GeniusYield/Test/Privnet/Utils.hs | 44 +- src/GeniusYield/Test/Utils.hs | 371 +++--- src/GeniusYield/Transaction.hs | 1018 ++++++++-------- src/GeniusYield/Transaction/CBOR.hs | 89 +- src/GeniusYield/Transaction/CoinSelection.hs | 584 ++++----- .../Transaction/CoinSelection/Types.hs | 17 +- src/GeniusYield/Transaction/Common.hs | 186 +-- src/GeniusYield/TxBuilder.hs | 131 +- src/GeniusYield/TxBuilder/Class.hs | 1072 +++++++++-------- src/GeniusYield/TxBuilder/Common.hs | 493 ++++---- src/GeniusYield/TxBuilder/Errors.hs | 153 ++- src/GeniusYield/TxBuilder/IO.hs | 266 ++-- src/GeniusYield/TxBuilder/IO/Builder.hs | 188 +-- src/GeniusYield/TxBuilder/IO/Query.hs | 267 ++-- src/GeniusYield/TxBuilder/IO/Unsafe.hs | 15 +- src/GeniusYield/TxBuilder/Query/Class.hs | 667 +++++----- src/GeniusYield/TxBuilder/User.hs | 102 +- src/GeniusYield/Types.hs | 84 +- src/GeniusYield/Types/Ada.hs | 25 +- src/GeniusYield/Types/Address.hs | 1053 ++++++++-------- src/GeniusYield/Types/Certificate.hs | 59 +- src/GeniusYield/Types/Credential.hs | 121 +- src/GeniusYield/Types/DRep.hs | 23 +- src/GeniusYield/Types/Datum.hs | 205 ++-- src/GeniusYield/Types/Delegatee.hs | 19 +- src/GeniusYield/Types/Era.hs | 7 +- src/GeniusYield/Types/Key.hs | 726 ++++++----- src/GeniusYield/Types/Key/Class.hs | 5 +- src/GeniusYield/Types/Ledger.hs | 21 +- src/GeniusYield/Types/Logging.hs | 556 ++++----- src/GeniusYield/Types/Natural.hs | 162 +-- src/GeniusYield/Types/NetworkId.hs | 148 +-- src/GeniusYield/Types/OpenApi.hs | 84 +- src/GeniusYield/Types/PaymentKeyHash.hs | 250 ++-- src/GeniusYield/Types/PlutusVersion.hs | 90 +- src/GeniusYield/Types/ProtocolParameters.hs | 10 +- src/GeniusYield/Types/Providers.hs | 562 ++++----- src/GeniusYield/Types/PubKeyHash.hs | 252 ++-- src/GeniusYield/Types/Rational.hs | 146 +-- src/GeniusYield/Types/Redeemer.hs | 71 +- src/GeniusYield/Types/Script.hs | 953 ++++++++------- src/GeniusYield/Types/Script/ScriptHash.hs | 68 +- src/GeniusYield/Types/Script/SimpleScript.hs | 109 +- src/GeniusYield/Types/Slot.hs | 60 +- src/GeniusYield/Types/SlotConfig.hs | 309 ++--- src/GeniusYield/Types/StakeAddressInfo.hs | 14 +- src/GeniusYield/Types/StakeKeyHash.hs | 203 ++-- src/GeniusYield/Types/StakePoolId.hs | 341 +++--- src/GeniusYield/Types/Time.hs | 320 ++--- src/GeniusYield/Types/Tx.hs | 370 +++--- src/GeniusYield/Types/TxBody.hs | 183 +-- src/GeniusYield/Types/TxCert.hs | 28 +- src/GeniusYield/Types/TxCert/Internal.hs | 86 +- src/GeniusYield/Types/TxIn.hs | 146 +-- src/GeniusYield/Types/TxMetadata.hs | 90 +- src/GeniusYield/Types/TxMetadata/Internal.hs | 15 +- src/GeniusYield/Types/TxOut.hs | 105 +- src/GeniusYield/Types/TxOutRef.hs | 345 +++--- src/GeniusYield/Types/TxWdrl.hs | 70 +- src/GeniusYield/Types/UTxO.hs | 278 +++-- src/GeniusYield/Types/Value.hs | 956 ++++++++------- src/GeniusYield/Types/Wallet.hs | 140 ++- src/GeniusYield/Utils.hs | 44 +- .../GeniusYield/Test/Privnet/SimpleScripts.hs | 30 +- .../GeniusYield/Test/Privnet/Stake.hs | 4 +- .../GeniusYield/Test/Privnet/Stake/Key.hs | 20 +- .../GeniusYield/Test/Privnet/Stake/Utils.hs | 56 +- .../Test/Privnet/Stake/Validator.hs | 20 +- tests-privnet/atlas-privnet-tests.hs | 104 +- .../Test/Unified/BetRef/Operations.hs | 123 +- .../Test/Unified/BetRef/PlaceBet.hs | 266 ++-- .../Test/Unified/BetRef/TakePot.hs | 111 +- .../Test/Unified/OnChain/BetRef.hs | 154 +-- .../Test/Unified/OnChain/BetRef/Compiled.hs | 32 +- tests-unified/atlas-unified-tests.hs | 18 +- tests/GeniusYield/Test/CoinSelection.hs | 764 ++++++------ tests/GeniusYield/Test/Config.hs | 22 +- tests/GeniusYield/Test/GYTxBody.hs | 331 ++--- tests/GeniusYield/Test/GYTxSkeleton.hs | 411 ++++--- .../Test/OnChain/GuessRefInputDatum.hs | 49 +- .../OnChain/GuessRefInputDatum/Compiled.hs | 22 +- tests/GeniusYield/Test/Providers.hs | 500 ++++---- tests/GeniusYield/Test/Providers/Mashup.hs | 145 ++- tests/GeniusYield/Test/RefInput.hs | 85 +- tests/GeniusYield/Test/SlotConfig.hs | 95 +- tests/GeniusYield/Test/Stake.hs | 23 +- tests/atlas-tests.hs | 155 +-- 131 files changed, 13459 insertions(+), 12189 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 839d49f0..f819e03c 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -18,7 +18,7 @@ on: value: ${{ jobs.build.outputs.ATLAS_VERSION }} permissions: - contents: write + contents: read jobs: build: @@ -122,17 +122,8 @@ jobs: - name: Install fourmolu run: cabal install fourmolu --overwrite-policy=always - - name: Lint Haskell - run: | - find . -name '*.hs' -exec sh -c 'for file do fourmolu -i "$file"; done' sh {} + - - - name: Auto-commit lint - uses: stefanzweifel/git-auto-commit-action@v4 - with: - commit_message: fourmolu auto-commit - commit_user_name: GitHub Action - commit_user_email: action@github.com - branch: ${{ github.head_ref }} + - name: Run checks (fourmolu) + run: git ls-files -z '*.hs' | xargs -P 12 -0 fourmolu --mode check - name: Install LIBSODIUM run: | diff --git a/fourmolu.yaml b/fourmolu.yaml index 16e19972..c7f07713 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1,47 +1,7 @@ -# Number of spaces per indentation step indentation: 2 - -# Max line length for automatic line breaking -column-limit: none - -# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) -function-arrows: leading - -# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) -comma-style: trailing - -# Styling of import/export lists (choices: leading, trailing, or diff-friendly) -import-export-style: diff-friendly - -# Whether to full-indent or half-indent 'where' bindings past the preceding body -indent-wheres: false - -# Whether to leave a space before an opening record brace +comma-style: leading record-brace-space: true - -# Number of spaces between top-level declarations -newlines-between-decls: 1 - -# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) +indent-wheres: true +respectful: true haddock-style: multi-line - -# How to print module docstring -haddock-style-module: null - -# Styling of let blocks (choices: auto, inline, newline, or mixed) -let-style: auto - -# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) -in-style: right-align - -# Whether to put parentheses around a single constraint (choices: auto, always, or never) -single-constraint-parens: never - -# Output Unicode syntax (choices: detect, always, or never) -unicode: always - -# Give the programmer more choice on where to insert blank lines -respectful: false - -# Fixity information for operators -fixities: [] +newlines-between-decls: 1 diff --git a/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs b/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs index 65550ceb..20a196a4 100644 --- a/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs +++ b/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs @@ -1,25 +1,25 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-| + +{- | Module : GeniusYield.OnChain.AStakeValidator Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.OnChain.AStakeValidator - ( mkAStakeValidator - ) where +module GeniusYield.OnChain.AStakeValidator ( + mkAStakeValidator, +) where -import PlutusLedgerApi.V2 -import PlutusTx.Prelude as PlutusTx +import PlutusLedgerApi.V2 +import PlutusTx.Prelude as PlutusTx -{-# INLINABLE mkAStakeValidator #-} +{-# INLINEABLE mkAStakeValidator #-} mkAStakeValidator :: Address -> BuiltinData -> BuiltinData -> () mkAStakeValidator addr _ ctx' = case scriptContextPurpose ctx of Certifying _ -> () - Rewarding _ -> if paidToAddress then () else error () - _ -> error () + Rewarding _ -> if paidToAddress then () else error () + _ -> error () where ctx :: ScriptContext ctx = unsafeFromBuiltinData ctx' diff --git a/src-plutustx/GeniusYield/OnChain/AStakeValidator/Compiled.hs b/src-plutustx/GeniusYield/OnChain/AStakeValidator/Compiled.hs index b554ed60..aa699d64 100644 --- a/src-plutustx/GeniusYield/OnChain/AStakeValidator/Compiled.hs +++ b/src-plutustx/GeniusYield/OnChain/AStakeValidator/Compiled.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} -{-| + +{- | Module : GeniusYield.OnChain.AStakeValidator.Compiled Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.OnChain.AStakeValidator.Compiled ( - originalAStakeValidator, + originalAStakeValidator, ) where -import GeniusYield.OnChain.AStakeValidator -import PlutusCore.Version (plcVersion100) -import qualified PlutusLedgerApi.V2 -import qualified PlutusTx +import GeniusYield.OnChain.AStakeValidator +import PlutusCore.Version (plcVersion100) +import PlutusLedgerApi.V2 qualified +import PlutusTx qualified -originalAStakeValidator - :: PlutusLedgerApi.V2.Address - -> PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) +originalAStakeValidator :: + PlutusLedgerApi.V2.Address -> + PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) originalAStakeValidator addr = - $$(PlutusTx.compile [|| mkAStakeValidator ||]) + $$(PlutusTx.compile [||mkAStakeValidator||]) `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 addr diff --git a/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs b/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs index 157d93ff..db0817fd 100644 --- a/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs +++ b/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs @@ -1,25 +1,26 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-| + +{- | Module : GeniusYield.OnChain.Examples.ReadOracle Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.OnChain.Examples.ReadOracle - ( mkReadOracleValidator - ) where +module GeniusYield.OnChain.Examples.ReadOracle ( + mkReadOracleValidator, +) where + +import PlutusLedgerApi.V2 +import PlutusTx.Prelude as PlutusTx -import PlutusLedgerApi.V2 -import PlutusTx.Prelude as PlutusTx +{-# INLINEABLE mkReadOracleValidator #-} -{-# INLINABLE mkReadOracleValidator #-} -- | Fail if there are no reference inputs with input datums. mkReadOracleValidator :: BuiltinData -> BuiltinData -> BuiltinData -> () mkReadOracleValidator _ _ ctx' - | any (hasOutputDatum . txOutDatum) refins = () - | otherwise = error () + | any (hasOutputDatum . txOutDatum) refins = () + | otherwise = error () where ctx :: ScriptContext ctx = unsafeFromBuiltinData ctx' @@ -32,4 +33,4 @@ mkReadOracleValidator _ _ ctx' hasOutputDatum :: OutputDatum -> Bool hasOutputDatum (OutputDatum _) = True - hasOutputDatum _ = False + hasOutputDatum _ = False diff --git a/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle/Compiled.hs b/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle/Compiled.hs index 44d7ce8a..2fe3afd7 100644 --- a/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle/Compiled.hs +++ b/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle/Compiled.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} -{-| + +{- | Module : GeniusYield.OnChain.Examples.ReadOracle.Compiled Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.OnChain.Examples.ReadOracle.Compiled - ( readOracleValidator - ) where +module GeniusYield.OnChain.Examples.ReadOracle.Compiled ( + readOracleValidator, +) where -import qualified PlutusTx +import PlutusTx qualified -import GeniusYield.OnChain.Examples.ReadOracle +import GeniusYield.OnChain.Examples.ReadOracle readOracleValidator :: PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -readOracleValidator = $$(PlutusTx.compile [|| mkReadOracleValidator ||]) +readOracleValidator = $$(PlutusTx.compile [||mkReadOracleValidator||]) diff --git a/src-plutustx/GeniusYield/OnChain/TestToken.hs b/src-plutustx/GeniusYield/OnChain/TestToken.hs index de45be44..546e7f15 100644 --- a/src-plutustx/GeniusYield/OnChain/TestToken.hs +++ b/src-plutustx/GeniusYield/OnChain/TestToken.hs @@ -1,31 +1,30 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS -fno-strictness -fno-spec-constr -fno-specialise #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-| +{- | Module : GeniusYield.OnChain.TestToken Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.OnChain.TestToken ( - mkTestTokenPolicy, + mkTestTokenPolicy, ) where -import PlutusLedgerApi.V1.Value (flattenValue) -import PlutusLedgerApi.V2 -import PlutusTx.Prelude +import PlutusLedgerApi.V1.Value (flattenValue) +import PlutusLedgerApi.V2 +import PlutusTx.Prelude -{-# INLINABLE mkTestTokenPolicy #-} +{-# INLINEABLE mkTestTokenPolicy #-} mkTestTokenPolicy :: Integer -> TokenName -> TxOutRef -> BuiltinData -> BuiltinData -> () mkTestTokenPolicy amt tn utxo _ ctx' - | hasn'tUTxO = traceError "UTxO not consumed" - | tn /= tn' = traceError "wrong token" - | amt /= amt' = traceError "wrong amount" - | otherwise = () + | hasn'tUTxO = traceError "UTxO not consumed" + | tn /= tn' = traceError "wrong token" + | amt /= amt' = traceError "wrong amount" + | otherwise = () where ctx :: ScriptContext ctx = unsafeFromBuiltinData ctx' diff --git a/src-plutustx/GeniusYield/OnChain/TestToken/Compiled.hs b/src-plutustx/GeniusYield/OnChain/TestToken/Compiled.hs index 456ac5fc..29fb8250 100644 --- a/src-plutustx/GeniusYield/OnChain/TestToken/Compiled.hs +++ b/src-plutustx/GeniusYield/OnChain/TestToken/Compiled.hs @@ -1,29 +1,32 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} -{-| + +{- | Module : GeniusYield.OnChain.TestToken.Compiled Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.OnChain.TestToken.Compiled ( - originalTestTokenPolicy, + originalTestTokenPolicy, ) where -import GeniusYield.OnChain.TestToken -import qualified PlutusLedgerApi.V2 -import qualified PlutusTx +import GeniusYield.OnChain.TestToken import PlutusCore.Version (plcVersion100) +import PlutusLedgerApi.V2 qualified +import PlutusTx qualified -originalTestTokenPolicy - :: Integer -- ^ Count. - -> PlutusLedgerApi.V2.TokenName -- ^ Token name (e.g. @GOLD@). - -> PlutusLedgerApi.V2.TxOutRef -- ^ UTxO to base token on. - -> PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) +originalTestTokenPolicy :: + -- | Count. + Integer -> + -- | Token name (e.g. @GOLD@). + PlutusLedgerApi.V2.TokenName -> + -- | UTxO to base token on. + PlutusLedgerApi.V2.TxOutRef -> + PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) originalTestTokenPolicy count tn utxo = - $$(PlutusTx.compile [|| mkTestTokenPolicy ||]) + $$(PlutusTx.compile [||mkTestTokenPolicy||]) `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 count `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 tn `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 utxo diff --git a/src/GeniusYield/Api/TestTokens.hs b/src/GeniusYield/Api/TestTokens.hs index f7dae724..45397c20 100644 --- a/src/GeniusYield/Api/TestTokens.hs +++ b/src/GeniusYield/Api/TestTokens.hs @@ -1,33 +1,35 @@ -- TODO (simplify-genesis): Remove this module once user creation has been removed from test setup. -- See note: 'simplify-genesis'. -{-| + +{- | Module : GeniusYield.Api.TestTokens Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Api.TestTokens ( - mintTestTokens, + mintTestTokens, ) where -import GeniusYield.Scripts.TestToken -import GeniusYield.TxBuilder -import GeniusYield.Types +import GeniusYield.Scripts.TestToken +import GeniusYield.TxBuilder +import GeniusYield.Types -mintTestTokens :: GYTxUserQueryMonad m - => GYTokenName - -> Natural - -> m (GYAssetClass, GYTxSkeleton 'PlutusV2) +mintTestTokens :: + (GYTxUserQueryMonad m) => + GYTokenName -> + Natural -> + m (GYAssetClass, GYTxSkeleton 'PlutusV2) mintTestTokens tn amt = do - -- utxo to base token of. - utxo <- someUTxO PlutusV1 + -- utxo to base token of. + utxo <- someUTxO PlutusV1 - let amt' = toInteger (max 1 amt) -- mint at least 1 token. - policy = testTokenPolicy amt' tn utxo + let amt' = toInteger (max 1 amt) -- mint at least 1 token. + policy = testTokenPolicy amt' tn utxo - let txSkeleton = mustHaveInput (GYTxIn utxo GYTxInWitnessKey) - <> mustMint (GYMintScript policy) unitRedeemer tn amt' + let txSkeleton = + mustHaveInput (GYTxIn utxo GYTxInWitnessKey) + <> mustMint (GYMintScript policy) unitRedeemer tn amt' - return (GYToken (mintingPolicyId policy) tn, txSkeleton) + return (GYToken (mintingPolicyId policy) tn, txSkeleton) diff --git a/src/GeniusYield/CardanoApi/EraHistory.hs b/src/GeniusYield/CardanoApi/EraHistory.hs index be089635..6f367cbd 100644 --- a/src/GeniusYield/CardanoApi/EraHistory.hs +++ b/src/GeniusYield/CardanoApi/EraHistory.hs @@ -1,23 +1,22 @@ -{-| +{- | Module : GeniusYield.CardanoApi.EraHistory Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.CardanoApi.EraHistory ( extractEraSummaries, showEraSummaries, - getEraEndSlot - ) where + getEraEndSlot, +) where -import qualified Unsafe.Coerce as UNSAFE +import Unsafe.Coerce qualified as UNSAFE -import qualified Cardano.Api as Api -import Data.SOP.NonEmpty (nonEmptyLast) -import qualified Ouroboros.Consensus.Cardano.Block as Ouroboros -import qualified Ouroboros.Consensus.HardFork.History as Ouroboros +import Cardano.Api qualified as Api +import Data.SOP.NonEmpty (nonEmptyLast) +import Ouroboros.Consensus.Cardano.Block qualified as Ouroboros +import Ouroboros.Consensus.HardFork.History qualified as Ouroboros {- | Extract the 'Ouroboros.Summary' from Cardano 'Api.EraHistory'. @@ -40,6 +39,6 @@ showEraSummaries eraHist = show $ extractEraSummaries eraHist -- | Get the slot after which the current era ends. getEraEndSlot :: Api.EraHistory -> Maybe Api.SlotNo getEraEndSlot (extractEraSummaries -> Ouroboros.Summary summaries) = - case Ouroboros.eraEnd (nonEmptyLast summaries) of - Ouroboros.EraUnbounded -> Nothing - Ouroboros.EraEnd bound -> Just $! Ouroboros.boundSlot bound + case Ouroboros.eraEnd (nonEmptyLast summaries) of + Ouroboros.EraUnbounded -> Nothing + Ouroboros.EraEnd bound -> Just $! Ouroboros.boundSlot bound diff --git a/src/GeniusYield/CardanoApi/Query.hs b/src/GeniusYield/CardanoApi/Query.hs index 06bb460d..cd12273b 100644 --- a/src/GeniusYield/CardanoApi/Query.hs +++ b/src/GeniusYield/CardanoApi/Query.hs @@ -1,28 +1,30 @@ -{-| +{- | Module : GeniusYield.CardanoApi.Query Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.CardanoApi.Query ( - -- * Low-level query runners - queryCardanoMode, - queryConwayEra, - queryUTxO, - -- * Exception - CardanoQueryException (..), + -- * Low-level query runners + queryCardanoMode, + queryConwayEra, + queryUTxO, + + -- * Exception + CardanoQueryException (..), ) where -import Control.Exception (Exception, - throwIO) +import Control.Exception ( + Exception, + throwIO, + ) -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Ouroboros +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Ouroboros.Network.Protocol.LocalStateQuery.Type qualified as Ouroboros -import GeniusYield.Types +import GeniusYield.Types ------------------------------------------------------------------------------- -- Exception @@ -38,17 +40,17 @@ newtype CardanoQueryException = CardanoQueryException String queryCardanoMode :: Api.LocalNodeConnectInfo -> Api.QueryInMode a -> IO a queryCardanoMode info q = do - e <- Api.runExceptT $ Api.queryNodeLocalState info Ouroboros.VolatileTip q - case e of - Left err -> throwIO $ CardanoQueryException $ show err - Right x -> return x + e <- Api.runExceptT $ Api.queryNodeLocalState info Ouroboros.VolatileTip q + case e of + Left err -> throwIO $ CardanoQueryException $ show err + Right x -> return x queryConwayEra :: Api.LocalNodeConnectInfo -> Api.QueryInShelleyBasedEra ApiEra a -> IO a queryConwayEra info q = do - e <- queryCardanoMode info $ Api.QueryInEra $ Api.QueryInShelleyBasedEra Api.ShelleyBasedEraConway q - case e of - Left err -> throwIO $ CardanoQueryException $ show err - Right x -> return x + e <- queryCardanoMode info $ Api.QueryInEra $ Api.QueryInShelleyBasedEra Api.ShelleyBasedEraConway q + case e of + Left err -> throwIO $ CardanoQueryException $ show err + Right x -> return x queryUTxO :: Api.S.LocalNodeConnectInfo -> Api.QueryUTxOFilter -> IO GYUTxOs queryUTxO info q = fmap utxosFromApi $ queryConwayEra info $ Api.QueryUTxO q diff --git a/src/GeniusYield/Examples/Common.hs b/src/GeniusYield/Examples/Common.hs index 33bc6cb1..12dbf850 100644 --- a/src/GeniusYield/Examples/Common.hs +++ b/src/GeniusYield/Examples/Common.hs @@ -1,19 +1,18 @@ -{-| +{- | Module : GeniusYield.Examples.Common Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop -} - module GeniusYield.Examples.Common ( toDeBruijn, ) where -import qualified PlutusCore.DeBruijn as PLC -import qualified UntypedPlutusCore as UPLC +import PlutusCore.DeBruijn qualified as PLC +import UntypedPlutusCore qualified as UPLC toDeBruijn :: UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () toDeBruijn script = case UPLC.deBruijnTerm script of - Left exc -> error $ "Converting to deBruijn " ++ show (exc :: UPLC.FreeVariableError) - Right term' -> UPLC.termMapNames PLC.unNameDeBruijn term' + Left exc -> error $ "Converting to deBruijn " ++ show (exc :: UPLC.FreeVariableError) + Right term' -> UPLC.termMapNames PLC.unNameDeBruijn term' diff --git a/src/GeniusYield/Examples/Gift.hs b/src/GeniusYield/Examples/Gift.hs index e9e2fbad..77e70ec6 100644 --- a/src/GeniusYield/Examples/Gift.hs +++ b/src/GeniusYield/Examples/Gift.hs @@ -1,24 +1,23 @@ -{-| +{- | Module : GeniusYield.Examples.Gift Description : The simplest script imaginable, which does nothing: always succeeds. Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Examples.Gift ( - -- * Scripts - giftValidatorV1, - giftValidatorV2, + -- * Scripts + giftValidatorV1, + giftValidatorV2, ) where -import GeniusYield.Types +import GeniusYield.Types -import GeniusYield.Examples.Common (toDeBruijn) -import qualified PlutusLedgerApi.Common as Plutus -import qualified UntypedPlutusCore as UPLC -import qualified PlutusCore.Version as PLC +import GeniusYield.Examples.Common (toDeBruijn) +import PlutusCore.Version qualified as PLC +import PlutusLedgerApi.Common qualified as Plutus +import UntypedPlutusCore qualified as UPLC ------------------------------------------------------------------------------- -- Script @@ -26,17 +25,17 @@ import qualified PlutusCore.Version as PLC -- | A very simple script: @\\datum redeemer sc -> sc@ giftScript :: UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -giftScript - = UPLC.LamAbs ann datumName - $ UPLC.LamAbs ann redeemerName - $ UPLC.LamAbs ann scName - $ UPLC.Var ann scName +giftScript = + UPLC.LamAbs ann datumName $ + UPLC.LamAbs ann redeemerName $ + UPLC.LamAbs ann scName $ + UPLC.Var ann scName where ann = () - datumName = UPLC.Name "datum" (UPLC.Unique 0) + datumName = UPLC.Name "datum" (UPLC.Unique 0) redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) - scName = UPLC.Name "sc" (UPLC.Unique 2) + scName = UPLC.Name "sc" (UPLC.Unique 2) giftScript' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () giftScript' = toDeBruijn giftScript @@ -48,5 +47,6 @@ giftValidatorV2 :: GYValidator 'PlutusV2 giftValidatorV2 = validatorFromSerialisedScript giftValidatorPlutusSerialised giftValidatorPlutusSerialised :: Plutus.SerialisedScript -giftValidatorPlutusSerialised = Plutus.serialiseUPLC $ +giftValidatorPlutusSerialised = + Plutus.serialiseUPLC $ UPLC.Program () PLC.plcVersion100 giftScript' diff --git a/src/GeniusYield/Examples/Limbo.hs b/src/GeniusYield/Examples/Limbo.hs index 48917b60..70c34d48 100644 --- a/src/GeniusYield/Examples/Limbo.hs +++ b/src/GeniusYield/Examples/Limbo.hs @@ -1,23 +1,22 @@ -{-| +{- | Module : GeniusYield.Examples.Limbo Description : Another simple script: never succeeds. Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Examples.Limbo ( - limboValidatorV1, - limboValidatorV2, + limboValidatorV1, + limboValidatorV2, ) where -import GeniusYield.Types +import GeniusYield.Types -import GeniusYield.Examples.Common (toDeBruijn) -import qualified PlutusCore.Version as PLC -import qualified PlutusLedgerApi.Common as Plutus -import qualified UntypedPlutusCore as UPLC +import GeniusYield.Examples.Common (toDeBruijn) +import PlutusCore.Version qualified as PLC +import PlutusLedgerApi.Common qualified as Plutus +import UntypedPlutusCore qualified as UPLC ------------------------------------------------------------------------------- -- Script @@ -25,17 +24,17 @@ import qualified UntypedPlutusCore as UPLC -- | A very simple script: @\\datum redeemer sc -> ERROR@ limboScript :: UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -limboScript - = UPLC.LamAbs ann datumName - $ UPLC.LamAbs ann redeemerName - $ UPLC.LamAbs ann scName - $ UPLC.Error ann +limboScript = + UPLC.LamAbs ann datumName $ + UPLC.LamAbs ann redeemerName $ + UPLC.LamAbs ann scName $ + UPLC.Error ann where ann = () - datumName = UPLC.Name "datum" (UPLC.Unique 0) + datumName = UPLC.Name "datum" (UPLC.Unique 0) redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) - scName = UPLC.Name "sc" (UPLC.Unique 2) + scName = UPLC.Name "sc" (UPLC.Unique 2) limboScript' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () limboScript' = toDeBruijn limboScript @@ -47,5 +46,6 @@ limboValidatorV2 :: GYValidator 'PlutusV2 limboValidatorV2 = validatorFromSerialisedScript limboValidatorPlutusSerialised limboValidatorPlutusSerialised :: Plutus.SerialisedScript -limboValidatorPlutusSerialised = Plutus.serialiseUPLC $ +limboValidatorPlutusSerialised = + Plutus.serialiseUPLC $ UPLC.Program () PLC.plcVersion100 limboScript' diff --git a/src/GeniusYield/Examples/Treat.hs b/src/GeniusYield/Examples/Treat.hs index 7bc73433..50baaae1 100644 --- a/src/GeniusYield/Examples/Treat.hs +++ b/src/GeniusYield/Examples/Treat.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.Examples.Treat Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 @@ -8,21 +8,20 @@ Stability : develop This script is similar to "GeniusYield.Examples.Gift", except it uses @serializeData@ builtin. Therefore V1 version is invalid. - -} module GeniusYield.Examples.Treat ( - -- * Scripts - treatValidatorV1, - treatValidatorV2, + -- * Scripts + treatValidatorV1, + treatValidatorV2, ) where -import GeniusYield.Examples.Common -import GeniusYield.Types +import GeniusYield.Examples.Common +import GeniusYield.Types -import qualified PlutusCore as PLC -import qualified PlutusCore.Version as PLC -import qualified PlutusLedgerApi.Common as Plutus -import qualified UntypedPlutusCore as UPLC +import PlutusCore qualified as PLC +import PlutusCore.Version qualified as PLC +import PlutusLedgerApi.Common qualified as Plutus +import UntypedPlutusCore qualified as UPLC ------------------------------------------------------------------------------- -- Script @@ -30,25 +29,27 @@ import qualified UntypedPlutusCore as UPLC -- | A very simple script: @\\datum redeemer sc -> sc@ treatScript :: UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -treatScript - = UPLC.LamAbs ann datumName - $ UPLC.LamAbs ann redeemerName - $ UPLC.LamAbs ann scName - $ UPLC.Apply ann - (UPLC.Builtin ann PLC.SerialiseData) - (UPLC.Var ann scName) +treatScript = + UPLC.LamAbs ann datumName $ + UPLC.LamAbs ann redeemerName $ + UPLC.LamAbs ann scName $ + UPLC.Apply + ann + (UPLC.Builtin ann PLC.SerialiseData) + (UPLC.Var ann scName) where ann = () - datumName = UPLC.Name "datum" (UPLC.Unique 0) + datumName = UPLC.Name "datum" (UPLC.Unique 0) redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) - scName = UPLC.Name "sc" (UPLC.Unique 2) + scName = UPLC.Name "sc" (UPLC.Unique 2) treatScript' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () treatScript' = toDeBruijn treatScript treatValidatorPlutusSerialised :: Plutus.SerialisedScript -treatValidatorPlutusSerialised = Plutus.serialiseUPLC $ +treatValidatorPlutusSerialised = + Plutus.serialiseUPLC $ UPLC.Program () PLC.plcVersion100 treatScript' treatValidatorV1 :: GYValidator 'PlutusV1 diff --git a/src/GeniusYield/GYConfig.hs b/src/GeniusYield/GYConfig.hs index d010e260..5810e92c 100644 --- a/src/GeniusYield/GYConfig.hs +++ b/src/GeniusYield/GYConfig.hs @@ -1,46 +1,50 @@ {-# LANGUAGE TemplateHaskell #-} -{-| + +{- | Module : GeniusYield.GYConfig Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.GYConfig - ( GYCoreConfig (..) - , Confidential (..) - , GYCoreProviderInfo (..) - , withCfgProviders - , coreConfigIO - , coreProviderIO - , findMaestroTokenAndNetId - , isNodeKupo - , isMaestro - , isBlockfrost - ) where - -import Control.Exception (SomeException, bracket, try) -import qualified Data.Aeson as Aeson -import Data.Aeson.TH -import Data.Aeson.Types -import qualified Data.ByteString.Lazy as LBS -import Data.Char (toLower) -import qualified Data.Text as Text -import Data.Time (NominalDiffTime, diffUTCTime, - getCurrentTime) - -import qualified Cardano.Api as Api - -import GeniusYield.Imports -import qualified GeniusYield.Providers.Blockfrost as Blockfrost +module GeniusYield.GYConfig ( + GYCoreConfig (..), + Confidential (..), + GYCoreProviderInfo (..), + withCfgProviders, + coreConfigIO, + coreProviderIO, + findMaestroTokenAndNetId, + isNodeKupo, + isMaestro, + isBlockfrost, +) where + +import Control.Exception (SomeException, bracket, try) +import Data.Aeson qualified as Aeson +import Data.Aeson.TH +import Data.Aeson.Types +import Data.ByteString.Lazy qualified as LBS +import Data.Char (toLower) +import Data.Text qualified as Text +import Data.Time ( + NominalDiffTime, + diffUTCTime, + getCurrentTime, + ) + +import Cardano.Api qualified as Api + +import GeniusYield.Imports +import GeniusYield.Providers.Blockfrost qualified as Blockfrost + -- import qualified GeniusYield.Providers.CachedQueryUTxOs as CachedQuery -import qualified GeniusYield.Providers.Kupo as KupoApi -import qualified GeniusYield.Providers.Maestro as MaestroApi -import GeniusYield.Providers.Node (nodeStakeAddressInfo) -import qualified GeniusYield.Providers.Node as Node -import GeniusYield.ReadJSON (readJSON) -import GeniusYield.Types +import GeniusYield.Providers.Kupo qualified as KupoApi +import GeniusYield.Providers.Maestro qualified as MaestroApi +import GeniusYield.Providers.Node (nodeStakeAddressInfo) +import GeniusYield.Providers.Node qualified as Node +import GeniusYield.ReadJSON (readJSON) +import GeniusYield.Types -- | How many seconds to keep slots cached, before refetching the data. slotCachingTime :: NominalDiffTime @@ -87,26 +91,26 @@ coreProviderIO = readJSON isNodeKupo :: GYCoreProviderInfo -> Bool isNodeKupo GYNodeKupo {} = True -isNodeKupo _ = False +isNodeKupo _ = False isMaestro :: GYCoreProviderInfo -> Bool isMaestro GYMaestro {} = True -isMaestro _ = False +isMaestro _ = False isBlockfrost :: GYCoreProviderInfo -> Bool isBlockfrost GYBlockfrost {} = True -isBlockfrost _ = False +isBlockfrost _ = False findMaestroTokenAndNetId :: [GYCoreConfig] -> IO (Text, GYNetworkId) findMaestroTokenAndNetId configs = do - let config = find (isMaestro . cfgCoreProvider) configs - case config of - Nothing -> throwIO $ userError "Missing Maestro Configuration" - Just conf -> do - let netId = cfgNetworkId conf - case cfgCoreProvider conf of - GYMaestro (Confidential token) _ -> return (token, netId) - _ -> throwIO $ userError "Missing Maestro Token" + let config = find (isMaestro . cfgCoreProvider) configs + case config of + Nothing -> throwIO $ userError "Missing Maestro Configuration" + Just conf -> do + let netId = cfgNetworkId conf + case cfgCoreProvider conf of + GYMaestro (Confidential token) _ -> return (token, netId) + _ -> throwIO $ userError "Missing Maestro Token" {- | The config to initialize the GY framework with. @@ -118,13 +122,14 @@ In JSON format, this essentially corresponds to: -} data GYCoreConfig = GYCoreConfig { cfgCoreProvider :: !GYCoreProviderInfo - , cfgNetworkId :: !GYNetworkId - -- | List of scribes to register. - , cfgLogging :: ![GYLogScribeConfig] - -- | Optional switch to enable timing and logging of requests sent to provider. - , cfgLogTiming :: !(Maybe Bool) - -- , cfgUtxoCacheEnable :: !Bool + , cfgNetworkId :: !GYNetworkId + , cfgLogging :: ![GYLogScribeConfig] + -- ^ List of scribes to register. + , cfgLogTiming :: !(Maybe Bool) + -- ^ Optional switch to enable timing and logging of requests sent to provider. } + -- , cfgUtxoCacheEnable :: !Bool + deriving stock (Show) $( deriveFromJSON @@ -138,13 +143,13 @@ coreConfigIO :: FilePath -> IO GYCoreConfig coreConfigIO file = do bs <- LBS.readFile file case Aeson.eitherDecode' bs of - Left err -> throwIO $ userError err + Left err -> throwIO $ userError err Right cfg -> pure cfg nodeConnectInfo :: FilePath -> GYNetworkId -> Api.LocalNodeConnectInfo nodeConnectInfo path netId = Node.networkIdToLocalNodeConnectInfo netId path -withCfgProviders :: GYCoreConfig -> GYLogNamespace -> (GYProviders -> IO a) -> IO a +withCfgProviders :: GYCoreConfig -> GYLogNamespace -> (GYProviders -> IO a) -> IO a withCfgProviders GYCoreConfig { cfgCoreProvider @@ -152,8 +157,8 @@ withCfgProviders , cfgLogging , cfgLogTiming } - ns - f = + ns + f = do (gyGetParameters, gySlotActions', gyQueryUTxO', gyLookupDatum, gySubmitTx, gyAwaitTxConfirmed, gyGetStakeAddressInfo) <- case cfgCoreProvider of GYNodeKupo path kupoUrl -> do @@ -173,11 +178,12 @@ withCfgProviders GYMaestro (Confidential apiToken) turboSubmit -> do maestroApiEnv <- MaestroApi.networkIdToMaestroEnv apiToken cfgNetworkId maestroSlotActions <- makeSlotActions slotCachingTime $ MaestroApi.maestroGetSlotOfCurrentBlock maestroApiEnv - maestroGetParams <- makeGetParameters - (MaestroApi.maestroProtocolParams cfgNetworkId maestroApiEnv) - (MaestroApi.maestroSystemStart maestroApiEnv) - (MaestroApi.maestroEraHistory maestroApiEnv) - (MaestroApi.maestroStakePools maestroApiEnv) + maestroGetParams <- + makeGetParameters + (MaestroApi.maestroProtocolParams cfgNetworkId maestroApiEnv) + (MaestroApi.maestroSystemStart maestroApiEnv) + (MaestroApi.maestroEraHistory maestroApiEnv) + (MaestroApi.maestroStakePools maestroApiEnv) pure ( maestroGetParams , maestroSlotActions @@ -190,11 +196,12 @@ withCfgProviders GYBlockfrost (Confidential key) -> do let proj = Blockfrost.networkIdToProject cfgNetworkId key blockfrostSlotActions <- makeSlotActions slotCachingTime $ Blockfrost.blockfrostGetSlotOfCurrentBlock proj - blockfrostGetParams <- makeGetParameters - (Blockfrost.blockfrostProtocolParams cfgNetworkId proj) - (Blockfrost.blockfrostSystemStart proj) - (Blockfrost.blockfrostEraHistory proj) - (Blockfrost.blockfrostStakePools proj) + blockfrostGetParams <- + makeGetParameters + (Blockfrost.blockfrostProtocolParams cfgNetworkId proj) + (Blockfrost.blockfrostSystemStart proj) + (Blockfrost.blockfrostEraHistory proj) + (Blockfrost.blockfrostStakePools proj) pure ( blockfrostGetParams , blockfrostSlotActions @@ -206,11 +213,12 @@ withCfgProviders ) bracket (mkLogEnv ns cfgLogging) closeScribes $ \logEnv -> do - let gyLog' = GYLogConfiguration - { cfgLogNamespace = mempty - , cfgLogContexts = mempty - , cfgLogDirector = Left logEnv - } + let gyLog' = + GYLogConfiguration + { cfgLogNamespace = mempty + , cfgLogContexts = mempty + , cfgLogDirector = Left logEnv + } (gyQueryUTxO, gySlotActions) <- {-if cfgUtxoCacheEnable then do @@ -219,33 +227,39 @@ withCfgProviders let gySlotActions = gySlotActions' { gyWaitForNextBlock' = purgeCache >> gyWaitForNextBlock' gySlotActions'} pure (gyQueryUTxO, gySlotActions, f) else -} pure (gyQueryUTxO', gySlotActions') - let f' = maybe f (\case - True -> f . logTiming - False -> f) cfgLogTiming + let f' = + maybe + f + ( \case + True -> f . logTiming + False -> f + ) + cfgLogTiming e <- try $ f' GYProviders {..} case e of - Right a -> pure a - Left (err :: SomeException) -> do - logRun gyLog' GYError ((printf "ERROR: %s" $ show err) :: String) - throwIO err + Right a -> pure a + Left (err :: SomeException) -> do + logRun gyLog' GYError ((printf "ERROR: %s" $ show err) :: String) + throwIO err logTiming :: GYProviders -> GYProviders -logTiming providers@GYProviders {..} = GYProviders - { gyLookupDatum = gyLookupDatum' - , gySubmitTx = gySubmitTx' - , gyAwaitTxConfirmed = gyAwaitTxConfirmed' - , gySlotActions = gySlotActions' - , gyGetParameters = gyGetParameters' - , gyQueryUTxO = gyQueryUTxO' +logTiming providers@GYProviders {..} = + GYProviders + { gyLookupDatum = gyLookupDatum' + , gySubmitTx = gySubmitTx' + , gyAwaitTxConfirmed = gyAwaitTxConfirmed' + , gySlotActions = gySlotActions' + , gyGetParameters = gyGetParameters' + , gyQueryUTxO = gyQueryUTxO' , gyGetStakeAddressInfo = gyGetStakeAddressInfo' - , gyLog' = gyLog' + , gyLog' = gyLog' } where wrap :: String -> IO a -> IO a wrap msg m = do - (!a, !t) <- duration m - gyLog providers "" GYDebug $ msg <> " took " <> show t - pure a + (!a, !t) <- duration m + gyLog providers "" GYDebug $ msg <> " took " <> show t + pure a gyLookupDatum' :: GYLookupDatum gyLookupDatum' = wrap "gyLookupDatum" . gyLookupDatum @@ -257,45 +271,48 @@ logTiming providers@GYProviders {..} = GYProviders gyAwaitTxConfirmed' p = wrap "gyAwaitTxConfirmed" . gyAwaitTxConfirmed p gySlotActions' :: GYSlotActions - gySlotActions' = GYSlotActions + gySlotActions' = + GYSlotActions { gyGetSlotOfCurrentBlock' = wrap "gyGetSlotOfCurrentBlock" $ gyGetSlotOfCurrentBlock providers - , gyWaitForNextBlock' = wrap "gyWaitForNextBlock" $ gyWaitForNextBlock providers - , gyWaitUntilSlot' = wrap "gyWaitUntilSlot" . gyWaitUntilSlot providers + , gyWaitForNextBlock' = wrap "gyWaitForNextBlock" $ gyWaitForNextBlock providers + , gyWaitUntilSlot' = wrap "gyWaitUntilSlot" . gyWaitUntilSlot providers } gyGetParameters' :: GYGetParameters - gyGetParameters' = GYGetParameters + gyGetParameters' = + GYGetParameters { gyGetProtocolParameters' = wrap "gyGetProtocolParameters" $ gyGetProtocolParameters providers - , gyGetSystemStart' = wrap "gyGetSystemStart" $ gyGetSystemStart providers - , gyGetEraHistory' = wrap "gyGetEraHistory" $ gyGetEraHistory providers - , gyGetStakePools' = wrap "gyGetStakePools" $ gyGetStakePools providers - , gyGetSlotConfig' = wrap "gyGetSlotConfig" $ gyGetSlotConfig providers + , gyGetSystemStart' = wrap "gyGetSystemStart" $ gyGetSystemStart providers + , gyGetEraHistory' = wrap "gyGetEraHistory" $ gyGetEraHistory providers + , gyGetStakePools' = wrap "gyGetStakePools" $ gyGetStakePools providers + , gyGetSlotConfig' = wrap "gyGetSlotConfig" $ gyGetSlotConfig providers } gyQueryUTxO' :: GYQueryUTxO - gyQueryUTxO' = GYQueryUTxO - { gyQueryUtxosAtTxOutRefs' = wrap "gyQueryUtxosAtTxOutRefs" . gyQueryUtxosAtTxOutRefs providers - , gyQueryUtxosAtTxOutRefsWithDatums' = case gyQueryUtxosAtTxOutRefsWithDatums' gyQueryUTxO of + gyQueryUTxO' = + GYQueryUTxO + { gyQueryUtxosAtTxOutRefs' = wrap "gyQueryUtxosAtTxOutRefs" . gyQueryUtxosAtTxOutRefs providers + , gyQueryUtxosAtTxOutRefsWithDatums' = case gyQueryUtxosAtTxOutRefsWithDatums' gyQueryUTxO of Nothing -> Nothing - Just q -> Just $ wrap "gyQueryUtxosAtTxOutRefsWithDatums" . q - , gyQueryUtxoAtTxOutRef' = wrap "gyQueryUtxoAtTxOutRef" . gyQueryUtxoAtTxOutRef providers - , gyQueryUtxoRefsAtAddress' = wrap "gyQueryUtxoRefsAtAddress" . gyQueryUtxoRefsAtAddress providers - , gyQueryUtxosAtAddress' = \addr mac -> wrap "gyQueryUtxosAtAddress'" $ gyQueryUtxosAtAddress providers addr mac - , gyQueryUtxosAtAddressWithDatums' = case gyQueryUtxosAtAddressWithDatums' gyQueryUTxO of + Just q -> Just $ wrap "gyQueryUtxosAtTxOutRefsWithDatums" . q + , gyQueryUtxoAtTxOutRef' = wrap "gyQueryUtxoAtTxOutRef" . gyQueryUtxoAtTxOutRef providers + , gyQueryUtxoRefsAtAddress' = wrap "gyQueryUtxoRefsAtAddress" . gyQueryUtxoRefsAtAddress providers + , gyQueryUtxosAtAddress' = \addr mac -> wrap "gyQueryUtxosAtAddress'" $ gyQueryUtxosAtAddress providers addr mac + , gyQueryUtxosAtAddressWithDatums' = case gyQueryUtxosAtAddressWithDatums' gyQueryUTxO of Nothing -> Nothing - Just q -> Just $ \addr mac -> wrap "gyQueryUtxosAtAddressWithDatums'" $ q addr mac - , gyQueryUtxosAtAddresses' = wrap "gyQueryUtxosAtAddresses" . gyQueryUtxosAtAddresses providers - , gyQueryUtxosAtAddressesWithDatums' = case gyQueryUtxosAtAddressesWithDatums' gyQueryUTxO of + Just q -> Just $ \addr mac -> wrap "gyQueryUtxosAtAddressWithDatums'" $ q addr mac + , gyQueryUtxosAtAddresses' = wrap "gyQueryUtxosAtAddresses" . gyQueryUtxosAtAddresses providers + , gyQueryUtxosAtAddressesWithDatums' = case gyQueryUtxosAtAddressesWithDatums' gyQueryUTxO of Nothing -> Nothing - Just q -> Just $ wrap "gyQueryUtxosAtAddressesWithDatums" . q - , gyQueryUtxosAtPaymentCredential' = \cred -> wrap "gyQueryUtxosAtPaymentCredential" . gyQueryUtxosAtPaymentCredential providers cred - , gyQueryUtxosAtPaymentCredWithDatums' = case gyQueryUtxosAtPaymentCredWithDatums' gyQueryUTxO of + Just q -> Just $ wrap "gyQueryUtxosAtAddressesWithDatums" . q + , gyQueryUtxosAtPaymentCredential' = \cred -> wrap "gyQueryUtxosAtPaymentCredential" . gyQueryUtxosAtPaymentCredential providers cred + , gyQueryUtxosAtPaymentCredWithDatums' = case gyQueryUtxosAtPaymentCredWithDatums' gyQueryUTxO of Nothing -> Nothing - Just q -> Just $ \cred mac -> wrap "gyQueryUtxosAtPaymentCredWithDatums" $ q cred mac - , gyQueryUtxosAtPaymentCredentials' = wrap "gyQueryUtxosAtPaymentCredentials" . gyQueryUtxosAtPaymentCredentials providers + Just q -> Just $ \cred mac -> wrap "gyQueryUtxosAtPaymentCredWithDatums" $ q cred mac + , gyQueryUtxosAtPaymentCredentials' = wrap "gyQueryUtxosAtPaymentCredentials" . gyQueryUtxosAtPaymentCredentials providers , gyQueryUtxosAtPaymentCredsWithDatums' = case gyQueryUtxosAtPaymentCredsWithDatums' gyQueryUTxO of Nothing -> Nothing - Just q -> Just $ wrap "gyQueryUtxosAtPaymentCredsWithDatums" . q + Just q -> Just $ wrap "gyQueryUtxosAtPaymentCredsWithDatums" . q } gyGetStakeAddressInfo' :: GYStakeAddress -> IO (Maybe GYStakeAddressInfo) @@ -303,7 +320,7 @@ logTiming providers@GYProviders {..} = GYProviders duration :: IO a -> IO (a, NominalDiffTime) duration m = do - start <- getCurrentTime - a <- m - end <- getCurrentTime - pure (a, end `diffUTCTime` start) + start <- getCurrentTime + a <- m + end <- getCurrentTime + pure (a, end `diffUTCTime` start) diff --git a/src/GeniusYield/HTTP/Errors.hs b/src/GeniusYield/HTTP/Errors.hs index a522596b..371d991e 100644 --- a/src/GeniusYield/HTTP/Errors.hs +++ b/src/GeniusYield/HTTP/Errors.hs @@ -1,24 +1,24 @@ {-# LANGUAGE DefaultSignatures #-} -{-| + +{- | Module : GeniusYield.HTTP.Errors Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.HTTP.Errors - ( IsGYApiError (..) - , GYApiError (..) - , someBackendError - ) where +module GeniusYield.HTTP.Errors ( + IsGYApiError (..), + GYApiError (..), + someBackendError, +) where -import Control.Exception (displayException) -import qualified Data.Text as Txt +import Control.Exception (displayException) +import Data.Text qualified as Txt -import Network.HTTP.Types (Status, status500) +import Network.HTTP.Types (Status, status500) -import GeniusYield.Imports +import GeniusYield.Imports ------------------------------------------------------------------------------- -- HTTP Api Errors @@ -27,31 +27,33 @@ import GeniusYield.Imports -- | Class of types that can be converted into an HTTP API error. type IsGYApiError :: Type -> Constraint class IsGYApiError e where - toApiError :: e -> GYApiError - default toApiError :: Exception e => e -> GYApiError - toApiError e = someBackendError . Txt.pack $ displayException e - --- | An example error code can be: "INSUFFICIENT_BALANCE" (i.e. --- it is not the HTTP status error message) --- --- The message can be any textual representation of the error with more information. --- --- The status code should be the HTTP status code. + toApiError :: e -> GYApiError + default toApiError :: (Exception e) => e -> GYApiError + toApiError e = someBackendError . Txt.pack $ displayException e + +{- | An example error code can be: "INSUFFICIENT_BALANCE" (i.e. + it is not the HTTP status error message) + + The message can be any textual representation of the error with more information. + + The status code should be the HTTP status code. +-} data GYApiError = GYApiError - { gaeErrorCode :: Text - , gaeHttpStatus :: Status - , gaeMsg :: Text - } - deriving stock (Show, Eq) + { gaeErrorCode :: Text + , gaeHttpStatus :: Status + , gaeMsg :: Text + } + deriving stock (Show, Eq) -instance Exception GYApiError where +instance Exception GYApiError instance IsGYApiError GYApiError where - toApiError = id + toApiError = id -- | Create a typical BACKEND_ERROR internal serval error with given message. someBackendError :: Text -> GYApiError -someBackendError msg = GYApiError +someBackendError msg = + GYApiError { gaeErrorCode = "BACKEND_ERROR" , gaeHttpStatus = status500 , gaeMsg = msg diff --git a/src/GeniusYield/Imports.hs b/src/GeniusYield/Imports.hs index 15e505ef..027412b4 100644 --- a/src/GeniusYield/Imports.hs +++ b/src/GeniusYield/Imports.hs @@ -1,96 +1,109 @@ {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-| + +{- | Module : GeniusYield.Imports Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Imports ( - module X, - pattern TODO, - findFirst, - decodeUtf8Lenient, - lazyDecodeUtf8Lenient, - hush, - hoistMaybe, + module X, + pattern TODO, + findFirst, + decodeUtf8Lenient, + lazyDecodeUtf8Lenient, + hush, + hoistMaybe, ) where -import Control.Applicative as X (liftA2) -import Control.Arrow as X ((>>>)) -import Control.Exception as X (Exception, catch, throwIO) -import Control.Monad as X (ap, foldM, forM, forM_, guard, - join, unless, when) -import Data.Aeson as X (FromJSON (..), ToJSON (..)) -import Data.Bifunctor as X (bimap, first, second) -import Data.Char as X (isAlphaNum, isHexDigit) -import Data.Coerce as X (coerce) -import Data.Either as X (fromRight) -import Data.Either.Combinators as X (rightToMaybe) -import Data.Foldable as X (find, foldl', toList) -import Data.Foldable.WithIndex as X (ifor_, itoList) -import Data.Function as X (on, (&)) -import Data.Functor as X (void, (<&>)) -import Data.Functor.Const as X (Const (..)) -import Data.Functor.Contravariant as X (Contravariant (..)) -import Data.Functor.Identity as X (Identity (..)) -import Data.Kind as X (Constraint, Type) -import Data.List as X (maximumBy, minimumBy, sortBy) -import Data.Map as X (Map) -import Data.Maybe as X (fromMaybe, isJust) -import Data.Proxy as X (Proxy (..)) -import Data.Set as X (Set) -import Data.Some as X (Some (..), withSome) -import Data.String as X (IsString (..)) -import Data.Text as X (Text) -import Data.Text.Encoding as X (encodeUtf8) -import Data.Type.Equality as X ((:~:) (..)) -import Data.Void as X (Void, absurd) -import GHC.Generics as X (Generic) -import GHC.Stack as X (CallStack, HasCallStack) -import Numeric.Natural as X (Natural) -import Text.Printf as X (PrintfArg (..), printf) -import Witherable as X (catMaybes, iwither, mapMaybe, - wither) +import Control.Applicative as X (liftA2) +import Control.Arrow as X ((>>>)) +import Control.Exception as X (Exception, catch, throwIO) +import Control.Monad as X ( + ap, + foldM, + forM, + forM_, + guard, + join, + unless, + when, + ) +import Data.Aeson as X (FromJSON (..), ToJSON (..)) +import Data.Bifunctor as X (bimap, first, second) +import Data.Char as X (isAlphaNum, isHexDigit) +import Data.Coerce as X (coerce) +import Data.Either as X (fromRight) +import Data.Either.Combinators as X (rightToMaybe) +import Data.Foldable as X (find, foldl', toList) +import Data.Foldable.WithIndex as X (ifor_, itoList) +import Data.Function as X (on, (&)) +import Data.Functor as X (void, (<&>)) +import Data.Functor.Const as X (Const (..)) +import Data.Functor.Contravariant as X (Contravariant (..)) +import Data.Functor.Identity as X (Identity (..)) +import Data.Kind as X (Constraint, Type) +import Data.List as X (maximumBy, minimumBy, sortBy) +import Data.Map as X (Map) +import Data.Maybe as X (fromMaybe, isJust) +import Data.Proxy as X (Proxy (..)) +import Data.Set as X (Set) +import Data.Some as X (Some (..), withSome) +import Data.String as X (IsString (..)) +import Data.Text as X (Text) +import Data.Text.Encoding as X (encodeUtf8) +import Data.Type.Equality as X ((:~:) (..)) +import Data.Void as X (Void, absurd) +import GHC.Generics as X (Generic) +import GHC.Stack as X (CallStack, HasCallStack) +import Numeric.Natural as X (Natural) +import Text.Printf as X (PrintfArg (..), printf) +import Witherable as X ( + catMaybes, + iwither, + mapMaybe, + wither, + ) -- Not re-exported. -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LBS -import Data.Monoid (First (..)) -import qualified Data.Text.Encoding as TE -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LTE -import GHC.TypeLits (ErrorMessage (..), TypeError) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Monoid (First (..)) +import Data.Text.Encoding qualified as TE +import Data.Text.Encoding.Error (lenientDecode) +import Data.Text.Lazy qualified as LT +import Data.Text.Lazy.Encoding qualified as LTE +import GHC.TypeLits (ErrorMessage (..), TypeError) -- | Use 'TODO' instead of 'undefined's -pattern TODO :: () => HasCallStack => a +pattern TODO :: () => (HasCallStack) => a pattern TODO <- (todoMatch -> ()) - where TODO = error "TODO" - + where + TODO = error "TODO" {-# DEPRECATED TODO "TODO left in the code" #-} todoMatch :: a -> () todoMatch _ = () -findFirst :: Foldable f => (a -> Maybe b) -> f a -> Maybe b +findFirst :: (Foldable f) => (a -> Maybe b) -> f a -> Maybe b findFirst f xs = getFirst (foldMap (coerce f) xs) -- poisonous instances -- (the orphan in plutus-ledger-api was removed in Feb 2022) -instance TypeError ('Text "Forbidden FromJSON ByteString instance") => FromJSON ByteString where - parseJSON = error "FromJSON @ByteString" +instance (TypeError ('Text "Forbidden FromJSON ByteString instance")) => FromJSON ByteString where + parseJSON = error "FromJSON @ByteString" + +instance (TypeError ('Text "Forbidden ToJSON ByteString instance")) => ToJSON ByteString where + toJSON = error "ToJSON @ByteString" -instance TypeError ('Text "Forbidden ToJSON ByteString instance") => ToJSON ByteString where - toJSON = error "ToJSON @ByteString" +{- | Decode a lazy 'ByteString' containing UTF-8 encoded text. --- | Decode a lazy 'ByteString' containing UTF-8 encoded text. --- --- Any invalid input bytes will be replaced with the Unicode replacement --- character U+FFFD. +Any invalid input bytes will be replaced with the Unicode replacement +character U+FFFD. +-} lazyDecodeUtf8Lenient :: LBS.ByteString -> LT.Text lazyDecodeUtf8Lenient = LTE.decodeUtf8With lenientDecode @@ -102,8 +115,9 @@ decodeUtf8Lenient = TE.decodeUtf8With lenientDecode hush :: Either e a -> Maybe a hush = either (const Nothing) Just --- | Convert a 'Maybe' computation to 'MaybeT'. --- --- __NOTE:__ This is also defined (& exported) in @transformers-0.6.0.0@, so should be removed once we upgrade to it. +{- | Convert a 'Maybe' computation to 'MaybeT'. + +__NOTE:__ This is also defined (& exported) in @transformers-0.6.0.0@, so should be removed once we upgrade to it. +-} hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b hoistMaybe = MaybeT . pure diff --git a/src/GeniusYield/Providers.hs b/src/GeniusYield/Providers.hs index 0fd07b93..e41a6758 100644 --- a/src/GeniusYield/Providers.hs +++ b/src/GeniusYield/Providers.hs @@ -1,17 +1,16 @@ -{-| +{- | Module : GeniusYield.Providers Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Providers - ( module X - ) where +module GeniusYield.Providers ( + module X, +) where -import GeniusYield.Providers.Blockfrost as X -import GeniusYield.Providers.CachedQueryUTxOs as X -import GeniusYield.Providers.Kupo as X -import GeniusYield.Providers.Maestro as X -import GeniusYield.Providers.Node as X +import GeniusYield.Providers.Blockfrost as X +import GeniusYield.Providers.CachedQueryUTxOs as X +import GeniusYield.Providers.Kupo as X +import GeniusYield.Providers.Maestro as X +import GeniusYield.Providers.Node as X diff --git a/src/GeniusYield/Providers/Blockfrost.hs b/src/GeniusYield/Providers/Blockfrost.hs index bac5b8d3..6b9fddd8 100644 --- a/src/GeniusYield/Providers/Blockfrost.hs +++ b/src/GeniusYield/Providers/Blockfrost.hs @@ -1,76 +1,79 @@ -module GeniusYield.Providers.Blockfrost - ( Blockfrost.Project - , blockfrostProtocolParams - , blockfrostStakePools - , blockfrostSystemStart - , blockfrostEraHistory - , blockfrostQueryUtxo - , blockfrostLookupDatum - , blockfrostGetSlotOfCurrentBlock - , blockfrostSubmitTx - , blockfrostAwaitTxConfirmed - , blockfrostStakeAddressInfo - , networkIdToProject - ) where - -import qualified Blockfrost.Client as Blockfrost -import qualified Cardano.Api as Api -import qualified Cardano.Api.Ledger as Api.L -import qualified Cardano.Api.Shelley as Api.S -import qualified Cardano.Ledger.Alonzo.PParams as Ledger -import qualified Cardano.Ledger.BaseTypes as Ledger -import qualified Cardano.Ledger.Coin as Ledger -import Cardano.Ledger.Conway.PParams (ConwayPParams (..), - THKD (..)) -import qualified Cardano.Ledger.Core as Ledger -import qualified Cardano.Ledger.Plutus as Ledger -import qualified Cardano.Slotting.Slot as CSlot -import qualified Cardano.Slotting.Time as CTime -import Control.Concurrent (threadDelay) -import Control.Monad ((<=<)) -import Control.Monad.Except (throwError) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Base16 as BS16 -import qualified Data.ByteString.Lazy as LBS -import Data.Either.Combinators (maybeToRight) -import Data.Foldable (fold) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Time.Clock.POSIX as Time -import qualified Money -import qualified Ouroboros.Consensus.HardFork.History as Ouroboros -import qualified PlutusTx.Builtins as Plutus -import qualified Web.HttpApiData as Web - -import Data.Default (def) -import GeniusYield.Imports -import GeniusYield.Providers.Common -import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) -import GeniusYield.Utils (serialiseToBech32WithPrefix) -import Ouroboros.Consensus.HardFork.History (EraParams (eraGenesisWin)) +module GeniusYield.Providers.Blockfrost ( + Blockfrost.Project, + blockfrostProtocolParams, + blockfrostStakePools, + blockfrostSystemStart, + blockfrostEraHistory, + blockfrostQueryUtxo, + blockfrostLookupDatum, + blockfrostGetSlotOfCurrentBlock, + blockfrostSubmitTx, + blockfrostAwaitTxConfirmed, + blockfrostStakeAddressInfo, + networkIdToProject, +) where + +import Blockfrost.Client qualified as Blockfrost +import Cardano.Api qualified as Api +import Cardano.Api.Ledger qualified as Api.L +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Ledger.Alonzo.PParams qualified as Ledger +import Cardano.Ledger.BaseTypes qualified as Ledger +import Cardano.Ledger.Coin qualified as Ledger +import Cardano.Ledger.Conway.PParams ( + ConwayPParams (..), + THKD (..), + ) +import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Plutus qualified as Ledger +import Cardano.Slotting.Slot qualified as CSlot +import Cardano.Slotting.Time qualified as CTime +import Control.Concurrent (threadDelay) +import Control.Monad ((<=<)) +import Control.Monad.Except (throwError) +import Data.Aeson qualified as Aeson +import Data.ByteString.Base16 qualified as BS16 +import Data.ByteString.Lazy qualified as LBS +import Data.Either.Combinators (maybeToRight) +import Data.Foldable (fold) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Time.Clock.POSIX qualified as Time +import Money qualified +import Ouroboros.Consensus.HardFork.History qualified as Ouroboros +import PlutusTx.Builtins qualified as Plutus +import Web.HttpApiData qualified as Web + +import Data.Default (def) +import GeniusYield.Imports +import GeniusYield.Providers.Common +import GeniusYield.Types +import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) +import GeniusYield.Utils (serialiseToBech32WithPrefix) +import Ouroboros.Consensus.HardFork.History (EraParams (eraGenesisWin)) data BlockfrostProviderException - = BlpvApiError !Text !Blockfrost.BlockfrostError - | BlpvDeserializeFailure !Text !SomeDeserializeError -- ^ This error should never actually happen (unless there's a bug). - | BlpvNoSlotInfo !Blockfrost.BlockHash - | BlpvUnsupportedOperation !Text - | BlpvIncorrectEraHistoryLength ![Blockfrost.NetworkEraSummary] - deriving stock (Eq, Show) - deriving anyclass (Exception) + = BlpvApiError !Text !Blockfrost.BlockfrostError + | -- | This error should never actually happen (unless there's a bug). + BlpvDeserializeFailure !Text !SomeDeserializeError + | BlpvNoSlotInfo !Blockfrost.BlockHash + | BlpvUnsupportedOperation !Text + | BlpvIncorrectEraHistoryLength ![Blockfrost.NetworkEraSummary] + deriving stock (Eq, Show) + deriving anyclass (Exception) throwBlpvApiError :: Text -> Blockfrost.BlockfrostError -> IO a throwBlpvApiError locationInfo = - throwIO . BlpvApiError locationInfo . silenceHeadersBlockfrostClientError + throwIO . BlpvApiError locationInfo . silenceHeadersBlockfrostClientError handleBlockfrostError :: Text -> Either Blockfrost.BlockfrostError a -> IO a handleBlockfrostError locationInfo = either (throwBlpvApiError locationInfo) pure silenceHeadersBlockfrostClientError :: Blockfrost.BlockfrostError -> Blockfrost.BlockfrostError silenceHeadersBlockfrostClientError (Blockfrost.ServantClientError e) = Blockfrost.ServantClientError $ silenceHeadersClientError e -silenceHeadersBlockfrostClientError other = other +silenceHeadersBlockfrostClientError other = other lovelacesToInteger :: Blockfrost.Lovelaces -> Integer lovelacesToInteger = fromIntegral @@ -80,16 +83,16 @@ gyAddressToBlockfrost = Blockfrost.mkAddress . addressToText gyPaymentCredentialToBlockfrost :: GYPaymentCredential -> Blockfrost.Address gyPaymentCredentialToBlockfrost cred = Blockfrost.mkAddress $ case cred of - GYPaymentCredentialByKey _ -> paymentCredentialToBech32 cred - GYPaymentCredentialByScript sh -> serialiseToBech32WithPrefix "addr_vkh" $ scriptHashToApi sh -- A bug in BF. + GYPaymentCredentialByKey _ -> paymentCredentialToBech32 cred + GYPaymentCredentialByScript sh -> serialiseToBech32WithPrefix "addr_vkh" $ scriptHashToApi sh -- A bug in BF. -- | Creates a 'GYValue' from a 'Blockfrost.Amount', may fail parsing blockfrost returned asset class. amountToValue :: Blockfrost.Amount -> Either Text GYValue amountToValue (Blockfrost.AdaAmount lovelaces) = pure . valueSingleton GYLovelace $ lovelacesToInteger lovelaces amountToValue (Blockfrost.AssetAmount sdiscr) = do - cs <- Web.parseUrlPiece csPart - tkName <- Web.parseUrlPiece tkNamePart - pure . valueSingleton (GYToken cs tkName) $ Money.someDiscreteAmount sdiscr + cs <- Web.parseUrlPiece csPart + tkName <- Web.parseUrlPiece tkNamePart + pure . valueSingleton (GYToken cs tkName) $ Money.someDiscreteAmount sdiscr where csAndTkname = Money.someDiscreteCurrency sdiscr -- Blockfrost uses no separator between CS and TkName. @@ -101,16 +104,20 @@ amountToValue (Blockfrost.AssetAmount sdiscr) = do blockfrostSubmitTx :: Blockfrost.Project -> GYSubmitTx blockfrostSubmitTx proj tx = do - txId <- handleBlockfrostSubmitError <=< Blockfrost.runBlockfrost proj + txId <- + handleBlockfrostSubmitError + <=< Blockfrost.runBlockfrost proj . Blockfrost.submitTx . Blockfrost.CBORString . LBS.fromStrict . Api.serialiseToCBOR - $ txToApi tx - either - (throwIO . BlpvDeserializeFailure locationIdent . DeserializeErrorHex . Text.pack) - pure - . txIdFromHexE . Text.unpack $ Blockfrost.unTxHash txId + $ txToApi tx + either + (throwIO . BlpvDeserializeFailure locationIdent . DeserializeErrorHex . Text.pack) + pure + . txIdFromHexE + . Text.unpack + $ Blockfrost.unTxHash txId where locationIdent = "SubmitTx" handleBlockfrostSubmitError = either (throwIO . SubmitTxException . Text.pack . show . silenceHeadersBlockfrostClientError) pure @@ -121,50 +128,58 @@ blockfrostSubmitTx proj tx = do -- | Awaits for the confirmation of a given 'GYTxId' blockfrostAwaitTxConfirmed :: Blockfrost.Project -> GYAwaitTx -blockfrostAwaitTxConfirmed proj p@GYAwaitTxParameters{..} txId = blpAwaitTx 0 +blockfrostAwaitTxConfirmed proj p@GYAwaitTxParameters {..} txId = blpAwaitTx 0 where blpAwaitTx :: Int -> IO () blpAwaitTx attempt | maxAttempts <= attempt = throwIO $ GYAwaitTxException p blpAwaitTx attempt = do - eTxInfo <- blockfrostQueryTx proj txId - case eTxInfo of - Left Blockfrost.BlockfrostNotFound -> threadDelay checkInterval >> - blpAwaitTx (attempt + 1) - Left err -> throwBlpvApiError "AwaitTx" err - Right txInfo -> blpAwaitBlock attempt $ - Blockfrost._transactionBlock txInfo + eTxInfo <- blockfrostQueryTx proj txId + case eTxInfo of + Left Blockfrost.BlockfrostNotFound -> + threadDelay checkInterval + >> blpAwaitTx (attempt + 1) + Left err -> throwBlpvApiError "AwaitTx" err + Right txInfo -> + blpAwaitBlock attempt $ + Blockfrost._transactionBlock txInfo blpAwaitBlock :: Int -> Blockfrost.BlockHash -> IO () blpAwaitBlock attempt _ | maxAttempts <= attempt = throwIO $ GYAwaitTxException p blpAwaitBlock attempt blockHash = do - eBlockInfo <- blockfrostQueryBlock proj blockHash - case eBlockInfo of - Left Blockfrost.BlockfrostNotFound -> threadDelay checkInterval >> - blpAwaitBlock (attempt + 1) blockHash - Left err -> throwBlpvApiError "AwaitBlock" err - - Right blockInfo | attempt + 1 == maxAttempts -> - when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ - throwIO $ GYAwaitTxException p - - Right blockInfo -> - when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ - threadDelay checkInterval >> blpAwaitBlock (attempt + 1) blockHash - -blockfrostQueryBlock - :: Blockfrost.Project - -> Blockfrost.BlockHash - -> IO (Either Blockfrost.BlockfrostError Blockfrost.Block) -blockfrostQueryBlock proj = Blockfrost.runBlockfrost proj - . Blockfrost.getBlock . Right - -blockfrostQueryTx - :: Blockfrost.Project - -> GYTxId - -> IO (Either Blockfrost.BlockfrostError Blockfrost.Transaction) -blockfrostQueryTx proj = Blockfrost.runBlockfrost proj - . Blockfrost.getTx . Blockfrost.TxHash - . Api.serialiseToRawBytesHexText . txIdToApi + eBlockInfo <- blockfrostQueryBlock proj blockHash + case eBlockInfo of + Left Blockfrost.BlockfrostNotFound -> + threadDelay checkInterval + >> blpAwaitBlock (attempt + 1) blockHash + Left err -> throwBlpvApiError "AwaitBlock" err + Right blockInfo + | attempt + 1 == maxAttempts -> + when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ + throwIO $ + GYAwaitTxException p + Right blockInfo -> + when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ + threadDelay checkInterval >> blpAwaitBlock (attempt + 1) blockHash + +blockfrostQueryBlock :: + Blockfrost.Project -> + Blockfrost.BlockHash -> + IO (Either Blockfrost.BlockfrostError Blockfrost.Block) +blockfrostQueryBlock proj = + Blockfrost.runBlockfrost proj + . Blockfrost.getBlock + . Right + +blockfrostQueryTx :: + Blockfrost.Project -> + GYTxId -> + IO (Either Blockfrost.BlockfrostError Blockfrost.Transaction) +blockfrostQueryTx proj = + Blockfrost.runBlockfrost proj + . Blockfrost.getTx + . Blockfrost.TxHash + . Api.serialiseToRawBytesHexText + . txIdToApi ------------------------------------------------------------------------------- -- Slot actions @@ -172,179 +187,200 @@ blockfrostQueryTx proj = Blockfrost.runBlockfrost proj blockfrostGetSlotOfCurrentBlock :: Blockfrost.Project -> IO GYSlot blockfrostGetSlotOfCurrentBlock proj = do - Blockfrost.Block {_blockSlot=slotMaybe, _blockHash=hash} <- - Blockfrost.runBlockfrost proj Blockfrost.getLatestBlock >>= handleBlockfrostError "Slot" - case slotMaybe of - Nothing -> throwIO $ BlpvNoSlotInfo hash - Just x -> pure . slotFromApi . Api.SlotNo . fromInteger $ Blockfrost.unSlot x + Blockfrost.Block {_blockSlot = slotMaybe, _blockHash = hash} <- + Blockfrost.runBlockfrost proj Blockfrost.getLatestBlock >>= handleBlockfrostError "Slot" + case slotMaybe of + Nothing -> throwIO $ BlpvNoSlotInfo hash + Just x -> pure . slotFromApi . Api.SlotNo . fromInteger $ Blockfrost.unSlot x ------------------------------------------------------------------------------- -- Query UTxO ------------------------------------------------------------------------------- blockfrostQueryUtxo :: Blockfrost.Project -> GYQueryUTxO -blockfrostQueryUtxo proj = GYQueryUTxO - { gyQueryUtxosAtTxOutRefs' = blockfrostUtxosAtTxOutRefs proj - , gyQueryUtxosAtTxOutRefsWithDatums' = Nothing -- Will use the default implementation. - , gyQueryUtxoAtTxOutRef' = blockfrostUtxosAtTxOutRef proj - , gyQueryUtxoRefsAtAddress' = gyQueryUtxoRefsAtAddressDefault $ blockfrostUtxosAtAddress proj - , gyQueryUtxosAtAddresses' = gyQueryUtxoAtAddressesDefault $ blockfrostUtxosAtAddress proj - , gyQueryUtxosAtAddress' = blockfrostUtxosAtAddress proj - , gyQueryUtxosAtAddressWithDatums' = Nothing - , gyQueryUtxosAtAddressesWithDatums' = Nothing -- Will use the default implementation. - , gyQueryUtxosAtPaymentCredential' = blockfrostUtxosAtPaymentCredential proj - , gyQueryUtxosAtPaymentCredWithDatums' = Nothing -- Will use the default implementation. - , gyQueryUtxosAtPaymentCredentials' = gyQueryUtxoAtPaymentCredentialsDefault $ blockfrostUtxosAtPaymentCredential proj - , gyQueryUtxosAtPaymentCredsWithDatums' = Nothing -- Will use the default implementation. +blockfrostQueryUtxo proj = + GYQueryUTxO + { gyQueryUtxosAtTxOutRefs' = blockfrostUtxosAtTxOutRefs proj + , gyQueryUtxosAtTxOutRefsWithDatums' = Nothing -- Will use the default implementation. + , gyQueryUtxoAtTxOutRef' = blockfrostUtxosAtTxOutRef proj + , gyQueryUtxoRefsAtAddress' = gyQueryUtxoRefsAtAddressDefault $ blockfrostUtxosAtAddress proj + , gyQueryUtxosAtAddresses' = gyQueryUtxoAtAddressesDefault $ blockfrostUtxosAtAddress proj + , gyQueryUtxosAtAddress' = blockfrostUtxosAtAddress proj + , gyQueryUtxosAtAddressWithDatums' = Nothing + , gyQueryUtxosAtAddressesWithDatums' = Nothing -- Will use the default implementation. + , gyQueryUtxosAtPaymentCredential' = blockfrostUtxosAtPaymentCredential proj + , gyQueryUtxosAtPaymentCredWithDatums' = Nothing -- Will use the default implementation. + , gyQueryUtxosAtPaymentCredentials' = gyQueryUtxoAtPaymentCredentialsDefault $ blockfrostUtxosAtPaymentCredential proj + , gyQueryUtxosAtPaymentCredsWithDatums' = Nothing -- Will use the default implementation. } transformUtxo :: (Blockfrost.AddressUtxo, Maybe GYAnyScript) -> Either SomeDeserializeError GYUTxO transformUtxo (Blockfrost.AddressUtxo {..}, ms) = do - val <- bimap DeserializeErrorAssetClass fold $ traverse amountToValue _addressUtxoAmount - addr <- maybeToRight DeserializeErrorAddress $ addressFromTextMaybe $ Blockfrost.unAddress _addressUtxoAddress - ref <- first DeserializeErrorHex . Web.parseUrlPiece - $ Blockfrost.unTxHash _addressUtxoTxHash <> Text.pack ('#' : show _addressUtxoOutputIndex) - d <- outDatumFromBlockfrost _addressUtxoDataHash _addressUtxoInlineDatum - pure GYUTxO - { utxoRef = ref - , utxoAddress = addr - , utxoValue = val - , utxoOutDatum = d - , utxoRefScript = ms - } + val <- bimap DeserializeErrorAssetClass fold $ traverse amountToValue _addressUtxoAmount + addr <- maybeToRight DeserializeErrorAddress $ addressFromTextMaybe $ Blockfrost.unAddress _addressUtxoAddress + ref <- + first DeserializeErrorHex . Web.parseUrlPiece $ + Blockfrost.unTxHash _addressUtxoTxHash <> Text.pack ('#' : show _addressUtxoOutputIndex) + d <- outDatumFromBlockfrost _addressUtxoDataHash _addressUtxoInlineDatum + pure + GYUTxO + { utxoRef = ref + , utxoAddress = addr + , utxoValue = val + , utxoOutDatum = d + , utxoRefScript = ms + } blockfrostUtxosAtAddress :: Blockfrost.Project -> GYAddress -> Maybe GYAssetClass -> IO GYUTxOs blockfrostUtxosAtAddress proj addr mAssetClass = do - let extractedAssetClass = extractAssetClass mAssetClass - {- 'Blockfrost.getAddressUtxos' doesn't return all utxos at that address, only the first 100 or so. - Have to handle paging manually for all. -} - addrUtxos <- handler <=< Blockfrost.runBlockfrost proj - . Blockfrost.allPages $ \paged -> - case extractedAssetClass of - Nothing -> Blockfrost.getAddressUtxos' (gyAddressToBlockfrost addr) paged Blockfrost.Ascending - Just (ac, tn) -> Blockfrost.getAddressUtxosAsset' (gyAddressToBlockfrost addr) (Blockfrost.mkAssetId $ ac <> tn) paged Blockfrost.Ascending - addrUtxos' <- mapM (\x -> lookupScriptHashIO proj (Blockfrost._addressUtxoReferenceScriptHash x) >>= \mrs -> return (x, mrs)) addrUtxos - case traverse transformUtxo addrUtxos' of - Left err -> throwIO $ BlpvDeserializeFailure locationIdent err - Right x -> pure $ utxosFromList x + let extractedAssetClass = extractAssetClass mAssetClass + {- 'Blockfrost.getAddressUtxos' doesn't return all utxos at that address, only the first 100 or so. + Have to handle paging manually for all. -} + addrUtxos <- handler + <=< Blockfrost.runBlockfrost proj + . Blockfrost.allPages + $ \paged -> + case extractedAssetClass of + Nothing -> Blockfrost.getAddressUtxos' (gyAddressToBlockfrost addr) paged Blockfrost.Ascending + Just (ac, tn) -> Blockfrost.getAddressUtxosAsset' (gyAddressToBlockfrost addr) (Blockfrost.mkAssetId $ ac <> tn) paged Blockfrost.Ascending + addrUtxos' <- mapM (\x -> lookupScriptHashIO proj (Blockfrost._addressUtxoReferenceScriptHash x) >>= \mrs -> return (x, mrs)) addrUtxos + case traverse transformUtxo addrUtxos' of + Left err -> throwIO $ BlpvDeserializeFailure locationIdent err + Right x -> pure $ utxosFromList x where locationIdent = "AddressUtxos" -- This particular error is fine in this case, we can just return empty list. handler (Left Blockfrost.BlockfrostNotFound) = pure [] - handler other = handleBlockfrostError locationIdent other + handler other = handleBlockfrostError locationIdent other blockfrostUtxosAtPaymentCredential :: Blockfrost.Project -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs blockfrostUtxosAtPaymentCredential proj cred mAssetClass = do - let extractedAssetClass = extractAssetClass mAssetClass - {- 'Blockfrost.getAddressUtxos' doesn't return all utxos at that address, only the first 100 or so. - Have to handle paging manually for all. -} - credUtxos <- handler <=< Blockfrost.runBlockfrost proj - . Blockfrost.allPages $ \paged -> - case extractedAssetClass of - Nothing -> Blockfrost.getAddressUtxos' (gyPaymentCredentialToBlockfrost cred) paged Blockfrost.Ascending - Just (ac, tn) -> Blockfrost.getAddressUtxosAsset' (gyPaymentCredentialToBlockfrost cred) (Blockfrost.mkAssetId $ ac <> tn) paged Blockfrost.Ascending - credUtxos' <- mapM (\x -> lookupScriptHashIO proj (Blockfrost._addressUtxoReferenceScriptHash x) >>= \mrs -> return (x, mrs)) credUtxos - case traverse transformUtxo credUtxos' of - Left err -> throwIO $ BlpvDeserializeFailure locationIdent err - Right x -> pure $ utxosFromList x + let extractedAssetClass = extractAssetClass mAssetClass + {- 'Blockfrost.getAddressUtxos' doesn't return all utxos at that address, only the first 100 or so. + Have to handle paging manually for all. -} + credUtxos <- handler + <=< Blockfrost.runBlockfrost proj + . Blockfrost.allPages + $ \paged -> + case extractedAssetClass of + Nothing -> Blockfrost.getAddressUtxos' (gyPaymentCredentialToBlockfrost cred) paged Blockfrost.Ascending + Just (ac, tn) -> Blockfrost.getAddressUtxosAsset' (gyPaymentCredentialToBlockfrost cred) (Blockfrost.mkAssetId $ ac <> tn) paged Blockfrost.Ascending + credUtxos' <- mapM (\x -> lookupScriptHashIO proj (Blockfrost._addressUtxoReferenceScriptHash x) >>= \mrs -> return (x, mrs)) credUtxos + case traverse transformUtxo credUtxos' of + Left err -> throwIO $ BlpvDeserializeFailure locationIdent err + Right x -> pure $ utxosFromList x where locationIdent = "PaymentCredentialUtxos" -- This particular error is fine in this case, we can just return empty list. handler (Left Blockfrost.BlockfrostNotFound) = pure [] - handler other = handleBlockfrostError locationIdent other + handler other = handleBlockfrostError locationIdent other blockfrostUtxosAtTxOutRef :: Blockfrost.Project -> GYTxOutRef -> IO (Maybe GYUTxO) blockfrostUtxosAtTxOutRef proj ref = do - let (Api.serialiseToRawBytesHexText -> txId, utxoIdx) = first txIdToApi $ txOutRefToTuple ref - -- Get all UTxO outputs created by the tx id within the given tx out ref. - txOutMaybe <- handler - <=< Blockfrost.runBlockfrost proj . Blockfrost.getTxUtxos $ Blockfrost.TxHash txId - -- Get the specific UTxO for the given index. - let res = txOutMaybe >>= - find - (\(Blockfrost._utxoOutputOutputIndex -> idx) -> idx == toInteger utxoIdx) - . Blockfrost._transactionUtxosOutputs - case res of - Nothing -> pure Nothing - Just Blockfrost.UtxoOutput {..} -> do - val <- either - (throwIO . BlpvDeserializeFailure locationIdent . DeserializeErrorAssetClass) - (pure . fold) - $ traverse amountToValue _utxoOutputAmount - addr <- maybe - (throwIO $ BlpvDeserializeFailure locationIdent DeserializeErrorAddress) - pure - . addressFromTextMaybe $ Blockfrost.unAddress _utxoOutputAddress - d <- either - (throwIO . BlpvDeserializeFailure locationIdent) - return - $ outDatumFromBlockfrost _utxoOutputDataHash _utxoOutputInlineDatum - ms <- lookupScriptHashIO proj _utxoOutputReferenceScriptHash - pure $ Just GYUTxO - { utxoRef = ref - , utxoAddress = addr - , utxoValue = val - , utxoOutDatum = d + let (Api.serialiseToRawBytesHexText -> txId, utxoIdx) = first txIdToApi $ txOutRefToTuple ref + -- Get all UTxO outputs created by the tx id within the given tx out ref. + txOutMaybe <- + handler + <=< Blockfrost.runBlockfrost proj . Blockfrost.getTxUtxos + $ Blockfrost.TxHash txId + -- Get the specific UTxO for the given index. + let res = + txOutMaybe + >>= find + (\(Blockfrost._utxoOutputOutputIndex -> idx) -> idx == toInteger utxoIdx) + . Blockfrost._transactionUtxosOutputs + case res of + Nothing -> pure Nothing + Just Blockfrost.UtxoOutput {..} -> do + val <- + either + (throwIO . BlpvDeserializeFailure locationIdent . DeserializeErrorAssetClass) + (pure . fold) + $ traverse amountToValue _utxoOutputAmount + addr <- + maybe + (throwIO $ BlpvDeserializeFailure locationIdent DeserializeErrorAddress) + pure + . addressFromTextMaybe + $ Blockfrost.unAddress _utxoOutputAddress + d <- + either + (throwIO . BlpvDeserializeFailure locationIdent) + return + $ outDatumFromBlockfrost _utxoOutputDataHash _utxoOutputInlineDatum + ms <- lookupScriptHashIO proj _utxoOutputReferenceScriptHash + pure $ + Just + GYUTxO + { utxoRef = ref + , utxoAddress = addr + , utxoValue = val + , utxoOutDatum = d , utxoRefScript = ms } where -- This particular error is fine in this case, we can just return 'Nothing'. handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing - handler other = handleBlockfrostError locationIdent $ Just <$> other + handler other = handleBlockfrostError locationIdent $ Just <$> other locationIdent = "TxUtxos(single)" blockfrostUtxosAtTxOutRefs :: Blockfrost.Project -> [GYTxOutRef] -> IO GYUTxOs blockfrostUtxosAtTxOutRefs proj refs = do - {- This combines utxo refs with the same tx id, yielding a 'Map Api.TxId (Set Integer)'. - - That is, a map from transaction hash to a set of utxo indices within that transaction, - that the caller is interested in. - -} - let refMap = - Map.fromListWith (<>) - $ map ((\(!txId, !utxoIdx) -> (txIdToApi txId, Set.singleton $ toInteger utxoIdx)) . txOutRefToTuple) refs - {- For each tx id, query blockfrost for the utxo outputs produced by said tx. - - Once all the outputs are obtained, filter to only end up with the utxo indices the caller - is interested in. - -} - txUtxoMap <- handleBlockfrostError locationIndent <=< Blockfrost.runBlockfrost proj . flip Map.traverseWithKey refMap - $ \txId idxs -> do - res <- Blockfrost.tryError - $ Blockfrost.getTxUtxos . Blockfrost.TxHash $ Api.serialiseToRawBytesHexText txId - case res of - Left Blockfrost.BlockfrostNotFound -> pure [] - Left err -> throwError err - Right (Blockfrost._transactionUtxosOutputs -> outs) -> pure $ - filter (\(Blockfrost._utxoOutputOutputIndex -> idx) -> idx `Set.member` idxs) outs - -- Create a 'GYUTxOs' map from the 'Map Api.TxId [Blockfrost.UtxoOutput]', covering for deserialize failures. - txUtxoMap' <- foldM f Map.empty $ Map.toList txUtxoMap - case Map.traverseWithKey (traverse . transformUtxoOutput) txUtxoMap' of - Left err -> throwIO $ BlpvDeserializeFailure locationIndent err - Right res -> pure . utxosFromList . concat $ Map.elems res + {- This combines utxo refs with the same tx id, yielding a 'Map Api.TxId (Set Integer)'. + + That is, a map from transaction hash to a set of utxo indices within that transaction, + that the caller is interested in. + -} + let refMap = + Map.fromListWith (<>) $ + map ((\(!txId, !utxoIdx) -> (txIdToApi txId, Set.singleton $ toInteger utxoIdx)) . txOutRefToTuple) refs + {- For each tx id, query blockfrost for the utxo outputs produced by said tx. + + Once all the outputs are obtained, filter to only end up with the utxo indices the caller + is interested in. + -} + txUtxoMap <- handleBlockfrostError locationIndent <=< Blockfrost.runBlockfrost proj . flip Map.traverseWithKey refMap $ + \txId idxs -> do + res <- + Blockfrost.tryError $ + Blockfrost.getTxUtxos . Blockfrost.TxHash $ + Api.serialiseToRawBytesHexText txId + case res of + Left Blockfrost.BlockfrostNotFound -> pure [] + Left err -> throwError err + Right (Blockfrost._transactionUtxosOutputs -> outs) -> + pure $ + filter (\(Blockfrost._utxoOutputOutputIndex -> idx) -> idx `Set.member` idxs) outs + -- Create a 'GYUTxOs' map from the 'Map Api.TxId [Blockfrost.UtxoOutput]', covering for deserialize failures. + txUtxoMap' <- foldM f Map.empty $ Map.toList txUtxoMap + case Map.traverseWithKey (traverse . transformUtxoOutput) txUtxoMap' of + Left err -> throwIO $ BlpvDeserializeFailure locationIndent err + Right res -> pure . utxosFromList . concat $ Map.elems res where locationIndent = "TxUtxos" - f :: Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)] - -> (Api.S.TxId, [Blockfrost.UtxoOutput]) - -> IO (Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)]) + f :: + Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)] -> + (Api.S.TxId, [Blockfrost.UtxoOutput]) -> + IO (Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)]) f m (tid, os) = do - xs <- forM os $ \o -> lookupScriptHashIO proj (Blockfrost._utxoOutputReferenceScriptHash o) >>= \ms -> return (o, ms) - return $ Map.insert tid xs m + xs <- forM os $ \o -> lookupScriptHashIO proj (Blockfrost._utxoOutputReferenceScriptHash o) >>= \ms -> return (o, ms) + return $ Map.insert tid xs m -- | Helper to transform a 'Blockfrost.UtxoOutput' into a 'GYUTxO'. transformUtxoOutput :: Api.S.TxId -> (Blockfrost.UtxoOutput, Maybe GYAnyScript) -> Either SomeDeserializeError GYUTxO transformUtxoOutput txId (Blockfrost.UtxoOutput {..}, ms) = do - val <- bimap DeserializeErrorAssetClass fold $ traverse amountToValue _utxoOutputAmount - addr <- maybeToRight DeserializeErrorAddress . addressFromTextMaybe $ Blockfrost.unAddress _utxoOutputAddress - d <- outDatumFromBlockfrost _utxoOutputDataHash _utxoOutputInlineDatum - pure GYUTxO - { utxoRef = txOutRefFromApi . Api.TxIn txId . Api.TxIx $ fromInteger _utxoOutputOutputIndex - , utxoAddress = addr - , utxoValue = val - , utxoOutDatum = d - , utxoRefScript = ms - } + val <- bimap DeserializeErrorAssetClass fold $ traverse amountToValue _utxoOutputAmount + addr <- maybeToRight DeserializeErrorAddress . addressFromTextMaybe $ Blockfrost.unAddress _utxoOutputAddress + d <- outDatumFromBlockfrost _utxoOutputDataHash _utxoOutputInlineDatum + pure + GYUTxO + { utxoRef = txOutRefFromApi . Api.TxIn txId . Api.TxIx $ fromInteger _utxoOutputOutputIndex + , utxoAddress = addr + , utxoValue = val + , utxoOutDatum = d + , utxoRefScript = ms + } ------------------------------------------------------------------------------- -- Parameters @@ -352,81 +388,103 @@ transformUtxoOutput txId (Blockfrost.UtxoOutput {..}, ms) = do blockfrostProtocolParams :: GYNetworkId -> Blockfrost.Project -> IO ApiProtocolParameters blockfrostProtocolParams nid proj = do - Blockfrost.ProtocolParams {..} <- Blockfrost.runBlockfrost proj Blockfrost.getLatestEpochProtocolParams - >>= handleBlockfrostError "ProtocolParams" - pure $ Ledger.PParams $ populateMissingProtocolParameters nid $ + Blockfrost.ProtocolParams {..} <- + Blockfrost.runBlockfrost proj Blockfrost.getLatestEpochProtocolParams + >>= handleBlockfrostError "ProtocolParams" + pure $ + Ledger.PParams $ + populateMissingProtocolParameters nid $ ConwayPParams - { cppMinFeeA = THKD $ Ledger.Coin _protocolParamsMinFeeA - , cppMinFeeB = THKD $ Ledger.Coin _protocolParamsMinFeeB - , cppMaxBBSize = THKD $ fromIntegral _protocolParamsMaxBlockSize - , cppMaxTxSize = THKD $ fromIntegral _protocolParamsMaxTxSize - , cppMaxBHSize = THKD $ fromIntegral _protocolParamsMaxBlockHeaderSize - , cppKeyDeposit = THKD $ Ledger.Coin $ lovelacesToInteger _protocolParamsKeyDeposit - , cppPoolDeposit = THKD $ Ledger.Coin $ lovelacesToInteger _protocolParamsPoolDeposit - , cppEMax = THKD $ Ledger.EpochInterval . fromIntegral - $ _protocolParamsEMax - , cppNOpt = THKD $ fromIntegral _protocolParamsNOpt - , cppA0 = THKD $ fromMaybe (error "GeniusYield.Providers.Maestro.maestroProtocolParams: pool influence received from Maestro is out of bounds") $ Ledger.boundRational _protocolParamsA0 - , cppRho = THKD $ fromMaybe (error "GeniusYield.Providers.Maestro.maestroProtocolParams: monetory expansion parameter received from Maestro is out of bounds") $ Ledger.boundRational _protocolParamsRho - , cppTau = THKD $ fromMaybe (error "GeniusYield.Providers.Maestro.maestroProtocolParams: treasury expansion parameter received from Maestro is out of bounds") $ Ledger.boundRational _protocolParamsTau - , cppProtocolVersion = Ledger.ProtVer { - Ledger.pvMajor = Ledger.mkVersion _protocolParamsProtocolMajorVer & fromMaybe (error "GeniusYield.Providers.Maestro.maestroProtocolParams: major version received from Maestro is out of bounds"), - Ledger.pvMinor = fromIntegral _protocolParamsProtocolMinorVer - } - , cppMinPoolCost = THKD $ Ledger.Coin $ lovelacesToInteger _protocolParamsMinPoolCost - , cppCoinsPerUTxOByte = THKD $ Api.L.CoinPerByte $ Ledger.Coin $ lovelacesToInteger _protocolParamsCoinsPerUtxoSize - , cppCostModels = THKD $ Ledger.mkCostModels $ Map.fromList $ plutusV3CostModels errPath : Map.foldlWithKey' (\acc k x -> case k of - Blockfrost.PlutusV1 -> (Ledger.PlutusV1, either (error (errPath <> "Couldn't build PlutusV1 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV1 $ fromInteger <$> Map.elems x) : acc - Blockfrost.PlutusV2 -> (Ledger.PlutusV2, either (error (errPath <> "Couldn't build PlutusV2 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV2 $ fromInteger <$> Map.elems x) : acc - -- Don't care about non plutus cost models. - Blockfrost.Timelock -> acc - Blockfrost.PlutusV3 -> acc - - ) [] (Blockfrost.unCostModels _protocolParamsCostModels) - , cppPrices = THKD $ Ledger.Prices {Ledger.prSteps = fromMaybe (error (errPath <> "Couldn't bound Blockfrost's cpu steps")) $ Ledger.boundRational _protocolParamsPriceStep, Ledger.prMem = fromMaybe (error (errPath <> "Couldn't bound Blockfrost's memory units")) $ Ledger.boundRational _protocolParamsPriceMem} - , cppMaxTxExUnits = THKD $ Ledger.OrdExUnits $ Ledger.ExUnits { - Ledger.exUnitsSteps = - fromInteger $ Blockfrost.unQuantity _protocolParamsMaxTxExSteps, - Ledger.exUnitsMem = - fromInteger $ Blockfrost.unQuantity _protocolParamsMaxTxExMem - } - , cppMaxBlockExUnits = THKD $ Ledger.OrdExUnits $ Ledger.ExUnits { - Ledger.exUnitsSteps = - fromInteger $ Blockfrost.unQuantity _protocolParamsMaxBlockExSteps, - Ledger.exUnitsMem = - fromInteger $ Blockfrost.unQuantity _protocolParamsMaxBlockExMem - } - , cppMaxValSize = THKD $ fromIntegral $ Blockfrost.unQuantity _protocolParamsMaxValSize - , cppCollateralPercentage = THKD $ fromIntegral _protocolParamsCollateralPercent - , cppMaxCollateralInputs = THKD $ fromIntegral _protocolParamsMaxCollateralInputs - -- FIXME: Fetch these from provider. - , cppPoolVotingThresholds = THKD def - , cppDRepVotingThresholds = THKD def - , cppCommitteeMinSize = THKD 0 - , cppCommitteeMaxTermLength = THKD (Ledger.EpochInterval 0) - , cppGovActionLifetime = THKD (Ledger.EpochInterval 0) - , cppGovActionDeposit = THKD $ Ledger.Coin 0 - , cppDRepDeposit = THKD $ Ledger.Coin 0 - , cppDRepActivity = THKD (Ledger.EpochInterval 0) - , cppMinFeeRefScriptCostPerByte = THKD minBound - } + { cppMinFeeA = THKD $ Ledger.Coin _protocolParamsMinFeeA + , cppMinFeeB = THKD $ Ledger.Coin _protocolParamsMinFeeB + , cppMaxBBSize = THKD $ fromIntegral _protocolParamsMaxBlockSize + , cppMaxTxSize = THKD $ fromIntegral _protocolParamsMaxTxSize + , cppMaxBHSize = THKD $ fromIntegral _protocolParamsMaxBlockHeaderSize + , cppKeyDeposit = THKD $ Ledger.Coin $ lovelacesToInteger _protocolParamsKeyDeposit + , cppPoolDeposit = THKD $ Ledger.Coin $ lovelacesToInteger _protocolParamsPoolDeposit + , cppEMax = + THKD $ + Ledger.EpochInterval . fromIntegral $ + _protocolParamsEMax + , cppNOpt = THKD $ fromIntegral _protocolParamsNOpt + , cppA0 = THKD $ fromMaybe (error "GeniusYield.Providers.Maestro.maestroProtocolParams: pool influence received from Maestro is out of bounds") $ Ledger.boundRational _protocolParamsA0 + , cppRho = THKD $ fromMaybe (error "GeniusYield.Providers.Maestro.maestroProtocolParams: monetory expansion parameter received from Maestro is out of bounds") $ Ledger.boundRational _protocolParamsRho + , cppTau = THKD $ fromMaybe (error "GeniusYield.Providers.Maestro.maestroProtocolParams: treasury expansion parameter received from Maestro is out of bounds") $ Ledger.boundRational _protocolParamsTau + , cppProtocolVersion = + Ledger.ProtVer + { Ledger.pvMajor = Ledger.mkVersion _protocolParamsProtocolMajorVer & fromMaybe (error "GeniusYield.Providers.Maestro.maestroProtocolParams: major version received from Maestro is out of bounds") + , Ledger.pvMinor = fromIntegral _protocolParamsProtocolMinorVer + } + , cppMinPoolCost = THKD $ Ledger.Coin $ lovelacesToInteger _protocolParamsMinPoolCost + , cppCoinsPerUTxOByte = THKD $ Api.L.CoinPerByte $ Ledger.Coin $ lovelacesToInteger _protocolParamsCoinsPerUtxoSize + , cppCostModels = + THKD $ + Ledger.mkCostModels $ + Map.fromList $ + plutusV3CostModels errPath + : Map.foldlWithKey' + ( \acc k x -> case k of + Blockfrost.PlutusV1 -> (Ledger.PlutusV1, either (error (errPath <> "Couldn't build PlutusV1 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV1 $ fromInteger <$> Map.elems x) : acc + Blockfrost.PlutusV2 -> (Ledger.PlutusV2, either (error (errPath <> "Couldn't build PlutusV2 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV2 $ fromInteger <$> Map.elems x) : acc + -- Don't care about non plutus cost models. + Blockfrost.Timelock -> acc + Blockfrost.PlutusV3 -> acc + ) + [] + (Blockfrost.unCostModels _protocolParamsCostModels) + , cppPrices = THKD $ Ledger.Prices {Ledger.prSteps = fromMaybe (error (errPath <> "Couldn't bound Blockfrost's cpu steps")) $ Ledger.boundRational _protocolParamsPriceStep, Ledger.prMem = fromMaybe (error (errPath <> "Couldn't bound Blockfrost's memory units")) $ Ledger.boundRational _protocolParamsPriceMem} + , cppMaxTxExUnits = + THKD $ + Ledger.OrdExUnits $ + Ledger.ExUnits + { Ledger.exUnitsSteps = + fromInteger $ Blockfrost.unQuantity _protocolParamsMaxTxExSteps + , Ledger.exUnitsMem = + fromInteger $ Blockfrost.unQuantity _protocolParamsMaxTxExMem + } + , cppMaxBlockExUnits = + THKD $ + Ledger.OrdExUnits $ + Ledger.ExUnits + { Ledger.exUnitsSteps = + fromInteger $ Blockfrost.unQuantity _protocolParamsMaxBlockExSteps + , Ledger.exUnitsMem = + fromInteger $ Blockfrost.unQuantity _protocolParamsMaxBlockExMem + } + , cppMaxValSize = THKD $ fromIntegral $ Blockfrost.unQuantity _protocolParamsMaxValSize + , cppCollateralPercentage = THKD $ fromIntegral _protocolParamsCollateralPercent + , cppMaxCollateralInputs = THKD $ fromIntegral _protocolParamsMaxCollateralInputs + , -- FIXME: Fetch these from provider. + cppPoolVotingThresholds = THKD def + , cppDRepVotingThresholds = THKD def + , cppCommitteeMinSize = THKD 0 + , cppCommitteeMaxTermLength = THKD (Ledger.EpochInterval 0) + , cppGovActionLifetime = THKD (Ledger.EpochInterval 0) + , cppGovActionDeposit = THKD $ Ledger.Coin 0 + , cppDRepDeposit = THKD $ Ledger.Coin 0 + , cppDRepActivity = THKD (Ledger.EpochInterval 0) + , cppMinFeeRefScriptCostPerByte = THKD minBound + } where errPath = "GeniusYield.Providers.Blockfrost.blockfrostProtocolParams: " blockfrostStakePools :: Blockfrost.Project -> IO (Set Api.S.PoolId) blockfrostStakePools proj = do - {- 'Blockfrost.listPools' doesn't actually return all pools, only the first 100 or so. - Have to handle paging manually for all. -} - stkPools <- handleBlockfrostError locationIdent <=< Blockfrost.runBlockfrost proj - . Blockfrost.allPages $ \paged -> Blockfrost.listPools' paged Blockfrost.Ascending - -- The pool ids returned by blockfrost are in bech32. - let poolIdsEith = traverse - (Api.deserialiseFromBech32 (Api.proxyToAsType $ Proxy @Api.S.PoolId) . Blockfrost.unPoolId) - stkPools - case poolIdsEith of - -- Deserialization failure shouldn't happen on blockfrost returned pool id. - Left err -> throwIO . BlpvDeserializeFailure locationIdent $ DeserializeErrorBech32 err - Right has -> pure $ Set.fromList has + {- 'Blockfrost.listPools' doesn't actually return all pools, only the first 100 or so. + Have to handle paging manually for all. -} + stkPools <- handleBlockfrostError locationIdent + <=< Blockfrost.runBlockfrost proj + . Blockfrost.allPages + $ \paged -> Blockfrost.listPools' paged Blockfrost.Ascending + -- The pool ids returned by blockfrost are in bech32. + let poolIdsEith = + traverse + (Api.deserialiseFromBech32 (Api.proxyToAsType $ Proxy @Api.S.PoolId) . Blockfrost.unPoolId) + stkPools + case poolIdsEith of + -- Deserialization failure shouldn't happen on blockfrost returned pool id. + Left err -> throwIO . BlpvDeserializeFailure locationIdent $ DeserializeErrorBech32 err + Right has -> pure $ Set.fromList has where locationIdent = "ListPools" @@ -440,18 +498,21 @@ blockfrostEraHistory proj = do eraSumms <- Blockfrost.runBlockfrost proj Blockfrost.getNetworkEras >>= handleBlockfrostError "EraHistory" maybe (throwIO $ BlpvIncorrectEraHistoryLength eraSumms) pure $ parseEraHist mkEra eraSumms where - mkBound Blockfrost.NetworkEraBound {_boundEpoch, _boundSlot, _boundTime} = Ouroboros.Bound + mkBound Blockfrost.NetworkEraBound {_boundEpoch, _boundSlot, _boundTime} = + Ouroboros.Bound { boundTime = CTime.RelativeTime _boundTime , boundSlot = CSlot.SlotNo $ fromIntegral _boundSlot , boundEpoch = CSlot.EpochNo $ fromIntegral _boundEpoch } - mkEraParams Blockfrost.NetworkEraParameters {_parametersEpochLength, _parametersSlotLength, _parametersSafeZone} = Ouroboros.EraParams + mkEraParams Blockfrost.NetworkEraParameters {_parametersEpochLength, _parametersSlotLength, _parametersSafeZone} = + Ouroboros.EraParams { eraEpochSize = CSlot.EpochSize $ fromIntegral _parametersEpochLength , eraSlotLength = CTime.mkSlotLength _parametersSlotLength , eraSafeZone = Ouroboros.StandardSafeZone _parametersSafeZone - , eraGenesisWin = fromIntegral _parametersSafeZone -- TODO: Get it from provider? It is supposed to be 3k/f where k is security parameter (at present 2160) and f is active slot coefficient. Usually ledger set the safe zone size such that it guarantees at least k blocks... + , eraGenesisWin = fromIntegral _parametersSafeZone -- TODO: Get it from provider? It is supposed to be 3k/f where k is security parameter (at present 2160) and f is active slot coefficient. Usually ledger set the safe zone size such that it guarantees at least k blocks... } - mkEra Blockfrost.NetworkEraSummary {_networkEraStart, _networkEraEnd, _networkEraParameters} = Ouroboros.EraSummary + mkEra Blockfrost.NetworkEraSummary {_networkEraStart, _networkEraEnd, _networkEraParameters} = + Ouroboros.EraSummary { eraStart = mkBound _networkEraStart , eraEnd = Ouroboros.EraEnd $ mkBound _networkEraEnd , eraParams = mkEraParams _networkEraParameters @@ -463,15 +524,24 @@ blockfrostEraHistory proj = do blockfrostLookupDatum :: Blockfrost.Project -> GYLookupDatum blockfrostLookupDatum p dh = do - datumMaybe <- handler <=< Blockfrost.runBlockfrost p - . Blockfrost.getScriptDatum . Blockfrost.DatumHash . Text.pack . show $ datumHashToPlutus dh - mapM (\(Blockfrost.ScriptDatum v) -> case fromJson @Plutus.BuiltinData (Aeson.encode v) of - Left err -> throwIO $ BlpvDeserializeFailure locationIdent err - Right bd -> pure $ datumFromPlutus' bd) datumMaybe + datumMaybe <- + handler + <=< Blockfrost.runBlockfrost p + . Blockfrost.getScriptDatum + . Blockfrost.DatumHash + . Text.pack + . show + $ datumHashToPlutus dh + mapM + ( \(Blockfrost.ScriptDatum v) -> case fromJson @Plutus.BuiltinData (Aeson.encode v) of + Left err -> throwIO $ BlpvDeserializeFailure locationIdent err + Right bd -> pure $ datumFromPlutus' bd + ) + datumMaybe where -- This particular error is fine in this case, we can just return 'Nothing'. handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing - handler other = handleBlockfrostError locationIdent $ Just <$> other + handler other = handleBlockfrostError locationIdent $ Just <$> other locationIdent = "LookupDatum" ------------------------------------------------------------------------------- @@ -484,44 +554,51 @@ blockfrostStakeAddressInfo p saddr = do where -- This particular error is fine. handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing - handler other = handleBlockfrostError "Account" $ other <&> \accInfo -> - if Blockfrost._accountInfoActive accInfo then Just $ - GYStakeAddressInfo - { gyStakeAddressInfoDelegatedPool = Blockfrost._accountInfoPoolId accInfo >>= stakePoolIdFromTextMaybe . Blockfrost.unPoolId - , gyStakeAddressInfoAvailableRewards = fromInteger $ lovelacesToInteger $ Blockfrost._accountInfoWithdrawableAmount accInfo - } - else Nothing + handler other = + handleBlockfrostError "Account" $ + other <&> \accInfo -> + if Blockfrost._accountInfoActive accInfo + then + Just $ + GYStakeAddressInfo + { gyStakeAddressInfoDelegatedPool = Blockfrost._accountInfoPoolId accInfo >>= stakePoolIdFromTextMaybe . Blockfrost.unPoolId + , gyStakeAddressInfoAvailableRewards = fromInteger $ lovelacesToInteger $ Blockfrost._accountInfoWithdrawableAmount accInfo + } + else Nothing ------------------------------------------------------------------------------- -- Auxiliary functions ------------------------------------------------------------------------------- -- | Constructs a Blockfrost client. --- -networkIdToProject :: GYNetworkId -- ^ The network identifier. - -> Text -- ^ The Blockfrost project identifier. - -> Blockfrost.Project -networkIdToProject nid pid = Blockfrost.Project +networkIdToProject :: + -- | The network identifier. + GYNetworkId -> + -- | The Blockfrost project identifier. + Text -> + Blockfrost.Project +networkIdToProject nid pid = + Blockfrost.Project { projectEnv = networkIdToBlockfrost nid - , projectId = pid + , projectId = pid } networkIdToBlockfrost :: GYNetworkId -> Blockfrost.Env -networkIdToBlockfrost GYMainnet = Blockfrost.Mainnet +networkIdToBlockfrost GYMainnet = Blockfrost.Mainnet networkIdToBlockfrost GYTestnetPreprod = Blockfrost.Preprod networkIdToBlockfrost GYTestnetPreview = Blockfrost.Preview -networkIdToBlockfrost GYTestnetLegacy = Blockfrost.Testnet +networkIdToBlockfrost GYTestnetLegacy = Blockfrost.Testnet -- TODO: we need another mechanism to query private network data -networkIdToBlockfrost GYPrivnet{} = error "Private network is not supported by Blockfrost" +networkIdToBlockfrost GYPrivnet {} = error "Private network is not supported by Blockfrost" datumHashFromBlockfrost :: Blockfrost.DatumHash -> Either SomeDeserializeError GYDatumHash datumHashFromBlockfrost = first (DeserializeErrorHex . Text.pack) . datumHashFromHexE . Text.unpack . Blockfrost.unDatumHash datumFromBlockfrostCBOR :: Blockfrost.ScriptDatumCBOR -> Either SomeDeserializeError GYDatum datumFromBlockfrostCBOR d = do - bs <- fromEither $ BS16.decode $ Text.encodeUtf8 t - api <- fromEither $ Api.deserialiseFromCBOR Api.AsHashableScriptData bs - return $ datumFromApi' api + bs <- fromEither $ BS16.decode $ Text.encodeUtf8 t + api <- fromEither $ Api.deserialiseFromCBOR Api.AsHashableScriptData bs + return $ datumFromApi' api where t = Blockfrost._scriptDatumCborCbor d e = DeserializeErrorHex t @@ -531,33 +608,33 @@ datumFromBlockfrostCBOR d = do outDatumFromBlockfrost :: Maybe Blockfrost.DatumHash -> Maybe Blockfrost.InlineDatum -> Either SomeDeserializeError GYOutDatum outDatumFromBlockfrost mdh mind = do - mdh' <- mapM datumHashFromBlockfrost mdh - mind' <- mapM (datumFromBlockfrostCBOR . Blockfrost.unInlineDatum) mind - return $ case (mind', mdh') of - (Just ind, _ ) -> GYOutDatumInline ind - (Nothing , Just h ) -> GYOutDatumHash h - (Nothing , Nothing) -> GYOutDatumNone + mdh' <- mapM datumHashFromBlockfrost mdh + mind' <- mapM (datumFromBlockfrostCBOR . Blockfrost.unInlineDatum) mind + return $ case (mind', mdh') of + (Just ind, _) -> GYOutDatumInline ind + (Nothing, Just h) -> GYOutDatumHash h + (Nothing, Nothing) -> GYOutDatumNone lookupScriptHash :: Blockfrost.ScriptHash -> Blockfrost.BlockfrostClient (Maybe GYAnyScript) lookupScriptHash h = do - t <- Blockfrost._scriptType <$> Blockfrost.getScript h - case t of - Blockfrost.Timelock -> do - mjson <- Blockfrost._scriptJsonJson <$> Blockfrost.getScriptJSON h - case mjson of - Nothing -> return Nothing - Just json -> return $ GYSimpleScript <$> simpleScriptFromJSON json - _ -> do - mcbor <- Blockfrost._scriptCborCbor <$> Blockfrost.getScriptCBOR h - case mcbor of - Nothing -> return Nothing - Just cbor -> return $ case t of - Blockfrost.PlutusV1 -> GYPlutusScript <$> scriptFromCBOR @'PlutusV1 cbor - Blockfrost.PlutusV2 -> GYPlutusScript <$> scriptFromCBOR @'PlutusV2 cbor - Blockfrost.PlutusV3 -> GYPlutusScript <$> scriptFromCBOR @'PlutusV3 cbor + t <- Blockfrost._scriptType <$> Blockfrost.getScript h + case t of + Blockfrost.Timelock -> do + mjson <- Blockfrost._scriptJsonJson <$> Blockfrost.getScriptJSON h + case mjson of + Nothing -> return Nothing + Just json -> return $ GYSimpleScript <$> simpleScriptFromJSON json + _ -> do + mcbor <- Blockfrost._scriptCborCbor <$> Blockfrost.getScriptCBOR h + case mcbor of + Nothing -> return Nothing + Just cbor -> return $ case t of + Blockfrost.PlutusV1 -> GYPlutusScript <$> scriptFromCBOR @'PlutusV1 cbor + Blockfrost.PlutusV2 -> GYPlutusScript <$> scriptFromCBOR @'PlutusV2 cbor + Blockfrost.PlutusV3 -> GYPlutusScript <$> scriptFromCBOR @'PlutusV3 cbor lookupScriptHashIO :: Blockfrost.Project -> Maybe Blockfrost.ScriptHash -> IO (Maybe GYAnyScript) -lookupScriptHashIO _ Nothing = return Nothing +lookupScriptHashIO _ Nothing = return Nothing lookupScriptHashIO p (Just h) = do - e <- Blockfrost.runBlockfrost p $ lookupScriptHash h - handleBlockfrostError "lookupScriptHash" e + e <- Blockfrost.runBlockfrost p $ lookupScriptHash h + handleBlockfrostError "lookupScriptHash" e diff --git a/src/GeniusYield/Providers/CachedQueryUTxOs.hs b/src/GeniusYield/Providers/CachedQueryUTxOs.hs index 1b2763ca..8fd8da65 100644 --- a/src/GeniusYield/Providers/CachedQueryUTxOs.hs +++ b/src/GeniusYield/Providers/CachedQueryUTxOs.hs @@ -1,50 +1,50 @@ -{-| +{- | Module : GeniusYield.Providers.CachedQueryUTxOs Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Providers.CachedQueryUTxOs ( - CachedQueryUTxO, - makeCachedQueryUTxO, + CachedQueryUTxO, + makeCachedQueryUTxO, ) where -import qualified Data.Cache as Cache +import Data.Cache qualified as Cache -import GeniusYield.Imports -import GeniusYield.Types +import GeniusYield.Imports +import GeniusYield.Types data CachedQueryUTxO = CachedQueryUTxO - { _cquAddrCache :: !(Cache.Cache (GYAddress, Maybe GYAssetClass) GYUTxOs) - , _cquRefCache :: !(Cache.Cache GYTxOutRef (Maybe GYUTxO)) - , _cquPaymentCredCache :: !(Cache.Cache (GYPaymentCredential, Maybe GYAssetClass) GYUTxOs) - , _cquInfo :: !GYQueryUTxO - , _cquLog :: !GYLogConfiguration - } + { _cquAddrCache :: !(Cache.Cache (GYAddress, Maybe GYAssetClass) GYUTxOs) + , _cquRefCache :: !(Cache.Cache GYTxOutRef (Maybe GYUTxO)) + , _cquPaymentCredCache :: !(Cache.Cache (GYPaymentCredential, Maybe GYAssetClass) GYUTxOs) + , _cquInfo :: !GYQueryUTxO + , _cquLog :: !GYLogConfiguration + } -- | Return a cached 'GYQueryUTxO' and a cache clearing function. makeCachedQueryUTxO :: GYQueryUTxO -> GYLogConfiguration -> IO (GYQueryUTxO, IO ()) makeCachedQueryUTxO query log' = do - addrCache <- Cache.newCache Nothing - refCache <- Cache.newCache Nothing - paymentCredCache <- Cache.newCache Nothing - let purge = Cache.purge addrCache >> Cache.purge refCache >> Cache.purge paymentCredCache - return (cachedQueryUTxO $ CachedQueryUTxO addrCache refCache paymentCredCache query log', purge) + addrCache <- Cache.newCache Nothing + refCache <- Cache.newCache Nothing + paymentCredCache <- Cache.newCache Nothing + let purge = Cache.purge addrCache >> Cache.purge refCache >> Cache.purge paymentCredCache + return (cachedQueryUTxO $ CachedQueryUTxO addrCache refCache paymentCredCache query log', purge) cachedQueryUTxO :: CachedQueryUTxO -> GYQueryUTxO -cachedQueryUTxO q = GYQueryUTxO +cachedQueryUTxO q = + GYQueryUTxO (cachedUtxosAtTxOutRefs q) - Nothing -- Will use the default implementation. + Nothing -- Will use the default implementation. (cachedUtxoAtTxOutRef q) (gyQueryUtxoRefsAtAddressDefault $ cachedUtxosAtAddress q) (cachedUtxosAtAddress q) Nothing (gyQueryUtxoAtAddressesDefault $ cachedUtxosAtAddress q) - Nothing -- Will use the default implementation. + Nothing -- Will use the default implementation. (cachedUtxosAtPaymentCred q) - Nothing -- Will use the default implementation. + Nothing -- Will use the default implementation. (gyQueryUtxoAtPaymentCredentialsDefault $ cachedUtxosAtPaymentCred q) Nothing @@ -60,60 +60,59 @@ cachedUtxoAtTxOutRef (CachedQueryUTxO _ cache _ q _) ref = do res <- gyQueryUtxoAtTxOutRef' q ref Cache.insert cache ref res return res - Just res -> do return res cachedUtxosAtTxOutRefs :: CachedQueryUTxO -> [GYTxOutRef] -> IO GYUTxOs cachedUtxosAtTxOutRefs ctx@(CachedQueryUTxO _ cache _ q logCfg) refs = do - step1 <- forM refs $ \ref -> (ref, ) <$> Cache.lookup' cache ref + step1 <- forM refs $ \ref -> (ref,) <$> Cache.lookup' cache ref - -- refs with no results in cache. - let refs' = mapMaybe (\(ref, res) -> if isJust res then Nothing else Just ref) step1 - logRun logCfg GYDebug $ "TxOutRefs not in cache:\n" ++ unlines (map show refs') + -- refs with no results in cache. + let refs' = mapMaybe (\(ref, res) -> if isJust res then Nothing else Just ref) step1 + logRun logCfg GYDebug $ "TxOutRefs not in cache:\n" ++ unlines (map show refs') - -- query node for things not in cache - utxos <- gyQueryUtxosAtTxOutRefs' q refs' - storeCacheUTxO ctx utxos + -- query node for things not in cache + utxos <- gyQueryUtxosAtTxOutRefs' q refs' + storeCacheUTxO ctx utxos - -- Note: technically we should filter non-refs' from utxos, - -- there shouldn't be any such. - -- But we assume that utxosAtTxOutRefs well-behaves. + -- Note: technically we should filter non-refs' from utxos, + -- there shouldn't be any such. + -- But we assume that utxosAtTxOutRefs well-behaves. - -- combine - return $ utxos <> utxosFromList (mapMaybe (join . snd) step1) + -- combine + return $ utxos <> utxosFromList (mapMaybe (join . snd) step1) -- When we query complete UTxOs, -- we can store the pieces of resulting UTxOs in per-txoutref cache. storeCacheUTxO :: CachedQueryUTxO -> GYUTxOs -> IO () storeCacheUTxO (CachedQueryUTxO _ cache _ _ _) utxos = forUTxOs_ utxos $ \utxo -> - let ref = utxoRef utxo - in Cache.insert cache ref (Just utxo) + let ref = utxoRef utxo + in Cache.insert cache ref (Just utxo) cachedUtxosAtAddress :: CachedQueryUTxO -> GYAddress -> Maybe GYAssetClass -> IO GYUTxOs cachedUtxosAtAddress ctx@(CachedQueryUTxO cache _ _ q logCfg) addr mAssetClass = do m <- Cache.lookup' cache (addr, mAssetClass) case m of - Nothing -> do + Nothing -> do logRun logCfg GYDebug $ "address not cached: " <> show addr res <- gyQueryUtxosAtAddress' q addr mAssetClass Cache.insert cache (addr, mAssetClass) res storeCacheUTxO ctx res - return res + return res Just res -> do - logRun logCfg GYDebug $ "address cached:" <> show addr + logRun logCfg GYDebug $ "address cached:" <> show addr return res cachedUtxosAtPaymentCred :: CachedQueryUTxO -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs cachedUtxosAtPaymentCred ctx@(CachedQueryUTxO _ _ cache q logCfg) cred mAssetClass = do m <- Cache.lookup' cache (cred, mAssetClass) case m of - Nothing -> do + Nothing -> do logRun logCfg GYDebug $ "payment credential not cached: " <> show cred res <- gyQueryUtxosAtPaymentCredential' q cred mAssetClass Cache.insert cache (cred, mAssetClass) res storeCacheUTxO ctx res - return res + return res Just res -> do - logRun logCfg GYDebug $ "payment credential cached:" <> show cred + logRun logCfg GYDebug $ "payment credential cached:" <> show cred return res diff --git a/src/GeniusYield/Providers/Common.hs b/src/GeniusYield/Providers/Common.hs index 93fddd10..0f521ba2 100644 --- a/src/GeniusYield/Providers/Common.hs +++ b/src/GeniusYield/Providers/Common.hs @@ -1,118 +1,137 @@ {-# OPTIONS_GHC -Wno-orphans #-} -{-| + +{- | Module : GeniusYield.Providers.Common Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Providers.Common ( - SomeDeserializeError (..) - , SubmitTxException (..) - , plutusV3CostModels - , populateMissingProtocolParameters - , datumFromCBOR - , newServantClientEnv - , fromJson - , parseEraHist - , preprodEraHist - , previewEraHist - , mainnetEraHist - , silenceHeadersClientError - , extractAssetClass + SomeDeserializeError (..), + SubmitTxException (..), + plutusV3CostModels, + populateMissingProtocolParameters, + datumFromCBOR, + newServantClientEnv, + fromJson, + parseEraHist, + preprodEraHist, + previewEraHist, + mainnetEraHist, + silenceHeadersClientError, + extractAssetClass, ) where -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Base16 as BS16 -import qualified Data.ByteString.Lazy as LBS -import Data.Maybe (fromJust) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text +import Data.Aeson qualified as Aeson +import Data.ByteString.Base16 qualified as BS16 +import Data.ByteString.Lazy qualified as LBS +import Data.Maybe (fromJust) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text -import qualified Network.HTTP.Client as HttpClient -import qualified Network.HTTP.Client.TLS as HttpClientTLS -import PlutusTx (FromData, - fromData) -import qualified Servant.Client as Servant -import qualified Servant.Client.Core as Servant +import Network.HTTP.Client qualified as HttpClient +import Network.HTTP.Client.TLS qualified as HttpClientTLS +import PlutusTx ( + FromData, + fromData, + ) +import Servant.Client qualified as Servant +import Servant.Client.Core qualified as Servant -import qualified Cardano.Api as Api -import qualified Cardano.Api.Ledger as Ledger -import qualified Cardano.Api.Shelley as Api -import Cardano.Ledger.Conway.PParams (ConwayPParams (..), - THKD (..)) -import qualified Cardano.Ledger.Conway.PParams as Ledger -import qualified Cardano.Ledger.Plutus as Ledger -import Cardano.Slotting.Slot (EpochNo (..), - EpochSize (..)) -import Cardano.Slotting.Time (RelativeTime (RelativeTime), - mkSlotLength) -import Control.Exception (Exception) -import Data.Bifunctor (first) -import Data.Ratio ((%)) -import Data.SOP.NonEmpty (NonEmpty (NonEmptyCons, NonEmptyOne)) -import GeniusYield.Imports (Identity) -import GeniusYield.Types (GYNetworkId (..)) -import GeniusYield.Types.Datum (GYDatum, - datumFromApi') -import GeniusYield.Types.Script (mintingPolicyIdToText) -import GeniusYield.Types.Value (GYAssetClass (..), - tokenNameToHex) -import qualified Ouroboros.Consensus.Cardano.Block as Ouroboros -import qualified Ouroboros.Consensus.HardFork.History as Ouroboros -import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (eraGenesisWin)) -import Test.Cardano.Ledger.Core.Rational (unsafeBoundRational) +import Cardano.Api qualified as Api +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api +import Cardano.Ledger.Conway.PParams ( + ConwayPParams (..), + THKD (..), + ) +import Cardano.Ledger.Conway.PParams qualified as Ledger +import Cardano.Ledger.Plutus qualified as Ledger +import Cardano.Slotting.Slot ( + EpochNo (..), + EpochSize (..), + ) +import Cardano.Slotting.Time ( + RelativeTime (RelativeTime), + mkSlotLength, + ) +import Control.Exception (Exception) +import Data.Bifunctor (first) +import Data.Ratio ((%)) +import Data.SOP.NonEmpty (NonEmpty (NonEmptyCons, NonEmptyOne)) +import GeniusYield.Imports (Identity) +import GeniusYield.Types (GYNetworkId (..)) +import GeniusYield.Types.Datum ( + GYDatum, + datumFromApi', + ) +import GeniusYield.Types.Script (mintingPolicyIdToText) +import GeniusYield.Types.Value ( + GYAssetClass (..), + tokenNameToHex, + ) +import Ouroboros.Consensus.Cardano.Block qualified as Ouroboros +import Ouroboros.Consensus.HardFork.History qualified as Ouroboros +import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (eraGenesisWin)) +import Test.Cardano.Ledger.Core.Rational (unsafeBoundRational) deriving newtype instance Num EpochSize deriving newtype instance Num EpochNo data SomeDeserializeError - = DeserializeErrorBech32 !Api.Bech32DecodeError - | DeserializeErrorAeson !Text - | DeserializeErrorAssetClass !Text - | DeserializeErrorScriptDataJson !Api.ScriptDataJsonError - -- Api.RawBytesHexError isn't exported; use that if it gets exported + = DeserializeErrorBech32 !Api.Bech32DecodeError + | DeserializeErrorAeson !Text + | DeserializeErrorAssetClass !Text + | DeserializeErrorScriptDataJson !Api.ScriptDataJsonError + | -- Api.RawBytesHexError isn't exported; use that if it gets exported -- https://github.com/input-output-hk/cardano-node/issues/4579 - | DeserializeErrorHex !Text - | DeserializeErrorAddress - | DeserializeErrorImpossibleBranch !Text - deriving stock (Eq, Show) + DeserializeErrorHex !Text + | DeserializeErrorAddress + | DeserializeErrorImpossibleBranch !Text + deriving stock (Eq, Show) newtype SubmitTxException = SubmitTxException Text - deriving stock (Show) + deriving stock (Show) deriving anyclass (Exception) -- FIXME: Temporary, until remote providers us with it. plutusV3CostModels :: [Char] -> (Ledger.Language, Ledger.CostModel) plutusV3CostModels errPath = - ( Ledger.PlutusV3 - , either (error (errPath <> "Couldn't build PlutusV3 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV3 [100788, 420, 1, 1, 1000, 173, 0, 1, 1000, 59957, 4, 1, 11183, 32, 201305, 8356, 4, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 100, 100, 16000, 100, 94375, 32, 132994, 32, 61462, 4, 72010, 178, 0, 1, 22151, 32, 91189, 769, 4, 2, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 1000, 42921, 4, 2, 24548, 29498, 38, 1, 898148, 27279, 1, 51775, 558, 1, 39184, 1000, 60594, 1, 141895, 32, 83150, 32, 15299, 32, 76049, 1, 13169, 4, 22100, 10, 28999, 74, 1, 28999, 74, 1, 43285, 552, 1, 44749, 541, 1, 33852, 32, 68246, 32, 72362, 32, 7243, 32, 7391, 32, 11546, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 90434, 519, 0, 1, 74433, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 955506, 213312, 0, 2, 270652, 22588, 4, 1457325, 64566, 4, 20467, 1, 4, 0, 141992, 32, 100788, 420, 1, 1, 81663, 32, 59498, 32, 20142, 32, 24588, 32, 20744, 32, 25933, 32, 24623, 32, 43053543, 10, 53384111, 14333, 10, 43574283, 26308, 10, 16000, 100, 16000, 100, 962335, 18, 2780678, 6, 442008, 1, 52538055, 3756, 18, 267929, 18, 76433006, 8868, 18, 52948122, 18, 1995836, 36, 3227919, 12, 901022, 1, 166917843, 4307, 36, 284546, 36, 158221314, 26549, 36, 74698472, 36, 333849714, 1, 254006273, 72, 2174038, 72, 2261318, 64571, 4, 207616, 8310, 4, 1293828, 28716, 63, 0, 1, 1006041, 43623, 251, 0, 1]) - + ( Ledger.PlutusV3 + , either (error (errPath <> "Couldn't build PlutusV3 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV3 [100788, 420, 1, 1, 1000, 173, 0, 1, 1000, 59957, 4, 1, 11183, 32, 201305, 8356, 4, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 100, 100, 16000, 100, 94375, 32, 132994, 32, 61462, 4, 72010, 178, 0, 1, 22151, 32, 91189, 769, 4, 2, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 1000, 42921, 4, 2, 24548, 29498, 38, 1, 898148, 27279, 1, 51775, 558, 1, 39184, 1000, 60594, 1, 141895, 32, 83150, 32, 15299, 32, 76049, 1, 13169, 4, 22100, 10, 28999, 74, 1, 28999, 74, 1, 43285, 552, 1, 44749, 541, 1, 33852, 32, 68246, 32, 72362, 32, 7243, 32, 7391, 32, 11546, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 90434, 519, 0, 1, 74433, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 955506, 213312, 0, 2, 270652, 22588, 4, 1457325, 64566, 4, 20467, 1, 4, 0, 141992, 32, 100788, 420, 1, 1, 81663, 32, 59498, 32, 20142, 32, 24588, 32, 20744, 32, 25933, 32, 24623, 32, 43053543, 10, 53384111, 14333, 10, 43574283, 26308, 10, 16000, 100, 16000, 100, 962335, 18, 2780678, 6, 442008, 1, 52538055, 3756, 18, 267929, 18, 76433006, 8868, 18, 52948122, 18, 1995836, 36, 3227919, 12, 901022, 1, 166917843, 4307, 36, 284546, 36, 158221314, 26549, 36, 74698472, 36, 333849714, 1, 254006273, 72, 2174038, 72, 2261318, 64571, 4, 207616, 8310, 4, 1293828, 28716, 63, 0, 1, 1006041, 43623, 251, 0, 1] + ) -- FIXME: Temporary, until remote providers us with it. populateMissingProtocolParameters :: GYNetworkId -> Ledger.ConwayPParams Identity era -> Ledger.ConwayPParams Identity era populateMissingProtocolParameters nid pp = - pp { - cppPoolVotingThresholds = THKD $ Ledger.PoolVotingThresholds { - pvtPPSecurityGroup = commonPoolVotingThreshold, pvtMotionNoConfidence = commonPoolVotingThreshold, pvtHardForkInitiation = commonPoolVotingThreshold, pvtCommitteeNormal = commonPoolVotingThreshold, pvtCommitteeNoConfidence = commonPoolVotingThreshold} + pp + { cppPoolVotingThresholds = + THKD $ + Ledger.PoolVotingThresholds + { pvtPPSecurityGroup = commonPoolVotingThreshold + , pvtMotionNoConfidence = commonPoolVotingThreshold + , pvtHardForkInitiation = commonPoolVotingThreshold + , pvtCommitteeNormal = commonPoolVotingThreshold + , pvtCommitteeNoConfidence = commonPoolVotingThreshold + } , cppDRepVotingThresholds = THKD $ Ledger.DRepVotingThresholds {dvtUpdateToConstitution = unsafeBoundRational (75 % 100), dvtTreasuryWithdrawal = unsafeBoundRational (67 % 100), dvtPPTechnicalGroup = unsafeBoundRational (67 % 100), dvtPPNetworkGroup = unsafeBoundRational (67 % 100), dvtPPGovGroup = unsafeBoundRational (75 % 100), dvtPPEconomicGroup = unsafeBoundRational (67 % 100), dvtMotionNoConfidence = unsafeBoundRational (67 % 100), dvtHardForkInitiation = unsafeBoundRational (6 % 10), dvtCommitteeNormal = unsafeBoundRational (67 % 100), dvtCommitteeNoConfidence = unsafeBoundRational (6 % 10)} , cppCommitteeMinSize = THKD $ case nid of - GYMainnet -> 7 + GYMainnet -> 7 GYTestnetPreprod -> 7 GYTestnetPreview -> 0 - _anyOther -> error "cppCommitteeMinSize: unsupported network id" + _anyOther -> error "cppCommitteeMinSize: unsupported network id" , cppCommitteeMaxTermLength = THKD $ Ledger.EpochInterval $ case nid of GYMainnet -> 146 GYTestnetPreprod -> 146 GYTestnetPreview -> 365 _anyOther -> error "cppCommitteeMaxTermLength: unsupported network id" , cppGovActionLifetime = THKD $ Ledger.EpochInterval $ case nid of - GYMainnet -> 6 + GYMainnet -> 6 GYTestnetPreprod -> 6 GYTestnetPreview -> 30 - _anyOther -> error "cppGovActionLifetime: unsupported network id" + _anyOther -> error "cppGovActionLifetime: unsupported network id" , cppGovActionDeposit = THKD $ Ledger.Coin 100000000000 , cppDRepDeposit = THKD $ Ledger.Coin 500000000 , cppDRepActivity = THKD $ Ledger.EpochInterval 20 @@ -124,7 +143,7 @@ populateMissingProtocolParameters nid pp = -- | Get datum from bytes. datumFromCBOR :: Text -> Either SomeDeserializeError GYDatum datumFromCBOR d = do - bs <- fromEither $ BS16.decode $ Text.encodeUtf8 d + bs <- fromEither $ BS16.decode $ Text.encodeUtf8 d api <- fromEither $ Api.deserialiseFromCBOR Api.AsHashableScriptData bs return $ datumFromApi' api where @@ -138,23 +157,24 @@ datumFromCBOR d = do This is used as quick and simple way to hide confidential information such as API token. -} silenceHeadersClientError :: Servant.ClientError -> Servant.ClientError -silenceHeadersClientError (Servant.FailureResponse reqF res) = Servant.FailureResponse reqF { Servant.requestHeaders = mempty } res -silenceHeadersClientError other = other +silenceHeadersClientError (Servant.FailureResponse reqF res) = Servant.FailureResponse reqF {Servant.requestHeaders = mempty} res +silenceHeadersClientError other = other -- | Creates a new Servant 'Servant.ClientEnv' from a base url. newServantClientEnv :: String -> IO Servant.ClientEnv newServantClientEnv baseUrl = do - url <- Servant.parseBaseUrl baseUrl - manager <- if Servant.baseUrlScheme url == Servant.Https - then HttpClient.newManager HttpClientTLS.tlsManagerSettings - else HttpClient.newManager HttpClient.defaultManagerSettings - pure $ Servant.mkClientEnv manager url + url <- Servant.parseBaseUrl baseUrl + manager <- + if Servant.baseUrlScheme url == Servant.Https + then HttpClient.newManager HttpClientTLS.tlsManagerSettings + else HttpClient.newManager HttpClient.defaultManagerSettings + pure $ Servant.mkClientEnv manager url -fromJson :: FromData a => LBS.ByteString -> Either SomeDeserializeError a +fromJson :: (FromData a) => LBS.ByteString -> Either SomeDeserializeError a fromJson b = do - v <- first (DeserializeErrorAeson . Text.pack) $ Aeson.eitherDecode b - x <- first DeserializeErrorScriptDataJson $ Api.scriptDataFromJson Api.ScriptDataJsonDetailedSchema v - pure . fromJust . fromData $ Api.toPlutusData $ Api.getScriptData x + v <- first (DeserializeErrorAeson . Text.pack) $ Aeson.eitherDecode b + x <- first DeserializeErrorScriptDataJson $ Api.scriptDataFromJson Api.ScriptDataJsonDetailedSchema v + pure . fromJust . fromData $ Api.toPlutusData $ Api.getScriptData x {- | Convert a regular list of era summaries (a la Ogmios) into a typed EraHistory (a la Ouroboros). @@ -168,7 +188,8 @@ why one cannot trivially automate this. Well, unless one uses vectors, from dependent type land. -} parseEraHist :: (t -> Ouroboros.EraSummary) -> [t] -> Maybe Api.EraHistory -parseEraHist mkEra [byronEra, shelleyEra, allegraEra, maryEra, alonzoEra, babbageEra, conwayEra] = Just +parseEraHist mkEra [byronEra, shelleyEra, allegraEra, maryEra, alonzoEra, babbageEra, conwayEra] = + Just . Api.EraHistory . Ouroboros.mkInterpreter . Ouroboros.Summary @@ -190,7 +211,9 @@ __NOTE:__ This is only to be used for testing. Also see: "GeniusYield.CardanoApi.EraHistory.showEraHistory" -} preprodEraHist :: Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) -preprodEraHist = Ouroboros.mkInterpreter . Ouroboros.Summary +preprodEraHist = + Ouroboros.mkInterpreter + . Ouroboros.Summary . NonEmptyCons byronEra . NonEmptyCons shelleyEra . NonEmptyCons allegraEra @@ -199,44 +222,46 @@ preprodEraHist = Ouroboros.mkInterpreter . Ouroboros.Summary $ NonEmptyOne babbageEra where byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} + } shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin =0} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 0} + } babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } previewEraHist :: Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) -previewEraHist = Ouroboros.mkInterpreter . Ouroboros.Summary +previewEraHist = + Ouroboros.mkInterpreter + . Ouroboros.Summary . NonEmptyCons byronEra . NonEmptyCons shelleyEra . NonEmptyCons allegraEra @@ -245,44 +270,46 @@ previewEraHist = Ouroboros.mkInterpreter . Ouroboros.Summary $ NonEmptyOne babbageEra where byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} + } shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } mainnetEraHist :: Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) -mainnetEraHist = Ouroboros.mkInterpreter . Ouroboros.Summary +mainnetEraHist = + Ouroboros.mkInterpreter + . Ouroboros.Summary . NonEmptyCons byronEra . NonEmptyCons shelleyEra . NonEmptyCons allegraEra @@ -291,41 +318,41 @@ mainnetEraHist = Ouroboros.mkInterpreter . Ouroboros.Summary $ NonEmptyOne babbageEra where byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} + } shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } -- | Extract currency symbol & token name part of an `GYAssetClass` when it is of such a form. When input is @Just GYLovelace@ or @Nothing@, this function returns @Nothing@. extractAssetClass :: Maybe GYAssetClass -> Maybe (Text, Text) diff --git a/src/GeniusYield/Providers/GCP.hs b/src/GeniusYield/Providers/GCP.hs index d9a4d51c..ae7b8064 100644 --- a/src/GeniusYield/Providers/GCP.hs +++ b/src/GeniusYield/Providers/GCP.hs @@ -1,25 +1,24 @@ -{-| +{- | Module : GeniusYield.Providers.GCP Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Providers.GCP (gcpFormatter) where -import qualified Data.Text.Lazy as LTxt -import qualified Data.Text.Lazy.Builder as TxtB -import Language.Haskell.TH.Syntax +import Data.Text.Lazy qualified as LTxt +import Data.Text.Lazy.Builder qualified as TxtB +import Language.Haskell.TH.Syntax -import Data.Aeson (Value, (.=)) -import qualified Data.Aeson as Aeson -import Katip -import Katip.Scribes.Handle +import Data.Aeson (Value, (.=)) +import Data.Aeson qualified as Aeson +import Katip +import Katip.Scribes.Handle -import GeniusYield.Imports +import GeniusYield.Imports -gcpFormatter :: LogItem a => ItemFormatter a +gcpFormatter :: (LogItem a) => ItemFormatter a gcpFormatter withColor verb @@ -31,35 +30,39 @@ gcpFormatter , _itemTime = time , _itemNamespace = Namespace namespaces , _itemLoc = locMaybe - } - = TxtB.fromText - $ colorBySeverity withColor severity - $ LTxt.toStrict $ lazyDecodeUtf8Lenient $ Aeson.encode obj - where - obj = Aeson.object - [ "severity" .= toGCPSeverity severity - , "message" .= TxtB.toLazyText msgBuilder - , "extraPayload" .= payloadObject verb payload - , "time" .= time - , "threadId" .= tid - , "logging.googleapis.com/sourceLocation" .= (toGCPLoc <$> locMaybe) - , "logging.googleapis.com/labels" .= Aeson.object ["namespaces" .= namespaces] - ] + } = + TxtB.fromText $ + colorBySeverity withColor severity $ + LTxt.toStrict $ + lazyDecodeUtf8Lenient $ + Aeson.encode obj + where + obj = + Aeson.object + [ "severity" .= toGCPSeverity severity + , "message" .= TxtB.toLazyText msgBuilder + , "extraPayload" .= payloadObject verb payload + , "time" .= time + , "threadId" .= tid + , "logging.googleapis.com/sourceLocation" .= (toGCPLoc <$> locMaybe) + , "logging.googleapis.com/labels" .= Aeson.object ["namespaces" .= namespaces] + ] toGCPLoc :: Loc -> Value -toGCPLoc Loc {loc_filename, loc_package, loc_module, loc_start=(!lineNum, _)} = Aeson.object - [ "file" .= loc_filename +toGCPLoc Loc {loc_filename, loc_package, loc_module, loc_start = (!lineNum, _)} = + Aeson.object + [ "file" .= loc_filename , "package" .= loc_package - , "module" .= loc_module - , "line" .= lineNum + , "module" .= loc_module + , "line" .= lineNum ] toGCPSeverity :: Severity -> Text -toGCPSeverity DebugS = "DEBUG" -toGCPSeverity InfoS = "INFO" -toGCPSeverity NoticeS = "NOTICE" -toGCPSeverity WarningS = "WARNING" -toGCPSeverity ErrorS = "ERROR" -toGCPSeverity CriticalS = "CRITICAL" -toGCPSeverity AlertS = "ALERT" +toGCPSeverity DebugS = "DEBUG" +toGCPSeverity InfoS = "INFO" +toGCPSeverity NoticeS = "NOTICE" +toGCPSeverity WarningS = "WARNING" +toGCPSeverity ErrorS = "ERROR" +toGCPSeverity CriticalS = "CRITICAL" +toGCPSeverity AlertS = "ALERT" toGCPSeverity EmergencyS = "EMERGENCY" diff --git a/src/GeniusYield/Providers/Kupo.hs b/src/GeniusYield/Providers/Kupo.hs index a3256c90..6a2b9209 100644 --- a/src/GeniusYield/Providers/Kupo.hs +++ b/src/GeniusYield/Providers/Kupo.hs @@ -6,7 +6,6 @@ License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop -} - module GeniusYield.Providers.Kupo ( KupoApiEnv, newKupoApiEnv, @@ -16,55 +15,83 @@ module GeniusYield.Providers.Kupo ( kupoAwaitTxConfirmed, ) where -import qualified Cardano.Api as Api -import Control.Concurrent (threadDelay) -import Control.Monad ((<=<)) -import Data.Aeson (Value (Null), withObject, (.:)) -import Data.Char (toLower) -import Data.Maybe (listToMaybe) -import qualified Data.Text as Text -import Data.Word (Word64) -import Deriving.Aeson -import GeniusYield.Imports -import GeniusYield.Providers.Common (datumFromCBOR, extractAssetClass, - newServantClientEnv) -import GeniusYield.Types (GYAddress, GYAddressBech32, - GYAssetClass (..), GYAwaitTx, - GYAwaitTxException (GYAwaitTxException), - GYAwaitTxParameters (..), - GYDatum, GYDatumHash, - GYLookupDatum, - GYOutDatum (GYOutDatumHash, GYOutDatumInline, GYOutDatumNone), - GYPaymentCredential, - GYQueryUTxO (..), GYScriptHash, - GYTxId, GYTxOutRef, GYUTxO (..), - GYUTxOs, GYValue, - addressFromBech32, addressToText, - gyQueryUtxoAtAddressesDefault, - gyQueryUtxoAtPaymentCredentialsDefault, - gyQueryUtxoRefsAtAddressDefault, - gyQueryUtxosAtTxOutRefsDefault, - parseValueKM, - paymentCredentialToHexText, - scriptFromCBOR, - simpleScriptFromCBOR, txIdToApi, - txOutRefFromApiTxIdIx, - txOutRefToTuple', utxosFromList, - valueFromLovelace) -import qualified GeniusYield.Types as GYTypes (PlutusVersion (..)) -import GeniusYield.Types.Script (GYAnyScript (..)) -import Servant.API (Capture, Get, Header, - Headers (getResponse), JSON, - QueryFlag, QueryParam, - ResponseHeader (Header), - lookupResponseHeader, - type (:<|>) (..), (:>)) -import Servant.Client (ClientEnv, ClientError, ClientM, - client, runClientM) - --- $setup --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson +import Cardano.Api qualified as Api +import Control.Concurrent (threadDelay) +import Control.Monad ((<=<)) +import Data.Aeson (Value (Null), withObject, (.:)) +import Data.Char (toLower) +import Data.Maybe (listToMaybe) +import Data.Text qualified as Text +import Data.Word (Word64) +import Deriving.Aeson +import GeniusYield.Imports +import GeniusYield.Providers.Common ( + datumFromCBOR, + extractAssetClass, + newServantClientEnv, + ) +import GeniusYield.Types ( + GYAddress, + GYAddressBech32, + GYAssetClass (..), + GYAwaitTx, + GYAwaitTxException (GYAwaitTxException), + GYAwaitTxParameters (..), + GYDatum, + GYDatumHash, + GYLookupDatum, + GYOutDatum (GYOutDatumHash, GYOutDatumInline, GYOutDatumNone), + GYPaymentCredential, + GYQueryUTxO (..), + GYScriptHash, + GYTxId, + GYTxOutRef, + GYUTxO (..), + GYUTxOs, + GYValue, + addressFromBech32, + addressToText, + gyQueryUtxoAtAddressesDefault, + gyQueryUtxoAtPaymentCredentialsDefault, + gyQueryUtxoRefsAtAddressDefault, + gyQueryUtxosAtTxOutRefsDefault, + parseValueKM, + paymentCredentialToHexText, + scriptFromCBOR, + simpleScriptFromCBOR, + txIdToApi, + txOutRefFromApiTxIdIx, + txOutRefToTuple', + utxosFromList, + valueFromLovelace, + ) +import GeniusYield.Types qualified as GYTypes (PlutusVersion (..)) +import GeniusYield.Types.Script (GYAnyScript (..)) +import Servant.API ( + Capture, + Get, + Header, + Headers (getResponse), + JSON, + QueryFlag, + QueryParam, + ResponseHeader (Header), + lookupResponseHeader, + (:>), + type (:<|>) (..), + ) +import Servant.Client ( + ClientEnv, + ClientError, + ClientM, + client, + runClientM, + ) + +{- $setup +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +-} -- | Kupo api env. newtype KupoApiEnv = KupoApiEnv ClientEnv @@ -77,8 +104,8 @@ newKupoApiEnv baseUrl = KupoApiEnv <$> newServantClientEnv baseUrl data KupoProviderException = -- | Error from the Kupo API. KupoApiError !Text !ClientError - -- | Received an absurd response from Kupo. This shouldn't ever happen. - | KupoAbsurdResponse !Text + | -- | Received an absurd response from Kupo. This shouldn't ever happen. + KupoAbsurdResponse !Text deriving stock (Eq, Show) deriving anyclass (Exception) @@ -100,7 +127,7 @@ type Pattern = Text -- Will lower the first character for your type. data LowerFirst instance StringModifier LowerFirst where - getStringModifier "" = "" + getStringModifier "" = "" getStringModifier (c : cs) = toLower c : cs newtype KupoDatum = KupoDatum (Maybe GYDatum) @@ -115,15 +142,18 @@ newtype KupoDatum = KupoDatum (Maybe GYDatum) instance FromJSON KupoDatum where parseJSON v = -- Kupo returns "null" (under 200 response code) if it doesn't find the preimage. - if v == Null then pure $ KupoDatum Nothing - else - withObject "KupoDatum" - (\datumObject -> do - datumBytes <- datumObject .: "datum" - case datumFromCBOR datumBytes of - Left e -> fail $ show e - Right d -> pure $ KupoDatum (Just d) - ) v + if v == Null + then pure $ KupoDatum Nothing + else + withObject + "KupoDatum" + ( \datumObject -> do + datumBytes <- datumObject .: "datum" + case datumFromCBOR datumBytes of + Left e -> fail $ show e + Right d -> pure $ KupoDatum (Just d) + ) + v data KupoScriptLanguage = Native | PlutusV1 | PlutusV2 | PlutusV3 deriving stock (Eq, Ord, Show, Generic) @@ -143,21 +173,24 @@ newtype KupoScript = KupoScript (Maybe GYAnyScript) instance FromJSON KupoScript where parseJSON v = -- Kupo returns "null" (under 200 response code) if it doesn't find the preimage. - if v == Null then pure $ KupoScript Nothing - else - withObject "KupoScript" - (\scriptObject -> do - scriptHex <- scriptObject .: "script" - scriptLanguage <- scriptObject .: "language" - case scriptLanguage of - Native -> pure $ KupoScript $ GYSimpleScript <$> simpleScriptFromCBOR scriptHex - PlutusV1 -> pure $ KupoScript $ GYPlutusScript <$> scriptFromCBOR @'GYTypes.PlutusV1 scriptHex - PlutusV2 -> pure $ KupoScript $ GYPlutusScript <$> scriptFromCBOR @'GYTypes.PlutusV2 scriptHex - PlutusV3 -> pure $ KupoScript $ GYPlutusScript <$> scriptFromCBOR @'GYTypes.PlutusV3 scriptHex - ) v + if v == Null + then pure $ KupoScript Nothing + else + withObject + "KupoScript" + ( \scriptObject -> do + scriptHex <- scriptObject .: "script" + scriptLanguage <- scriptObject .: "language" + case scriptLanguage of + Native -> pure $ KupoScript $ GYSimpleScript <$> simpleScriptFromCBOR scriptHex + PlutusV1 -> pure $ KupoScript $ GYPlutusScript <$> scriptFromCBOR @'GYTypes.PlutusV1 scriptHex + PlutusV2 -> pure $ KupoScript $ GYPlutusScript <$> scriptFromCBOR @'GYTypes.PlutusV2 scriptHex + PlutusV3 -> pure $ KupoScript $ GYPlutusScript <$> scriptFromCBOR @'GYTypes.PlutusV3 scriptHex + ) + v data KupoValue = KupoValue - { coins :: !Natural + { coins :: !Natural , assets :: !GYValue } deriving stock (Show, Eq, Ord, Generic) @@ -178,27 +211,27 @@ instance FromJSON KupoValue where coins <- v .: "coins" assets' <- v .: "assets" assets <- parseValueKM True assets' - return KupoValue { coins = coins, assets = assets } + return KupoValue {coins = coins, assets = assets} data KupoDatumType = Hash | Inline deriving stock (Show, Eq, Ord, Generic) deriving (FromJSON) via CustomJSON '[ConstructorTagModifier '[LowerFirst]] KupoDatumType newtype KupoCreatedAt = KupoCreatedAt - { slotNo :: Word64 + { slotNo :: Word64 } deriving stock (Show, Eq, Ord, Generic) deriving (FromJSON) via CustomJSON '[FieldLabelModifier '[CamelToSnake]] KupoCreatedAt data KupoUtxo = KupoUtxo { transactionId :: !GYTxId - , outputIndex :: !Api.TxIx - , address :: !GYAddressBech32 - , value :: !KupoValue - , datumHash :: !(Maybe GYDatumHash) - , datumType :: !(Maybe KupoDatumType) - , scriptHash :: !(Maybe GYScriptHash) - , createdAt :: !KupoCreatedAt + , outputIndex :: !Api.TxIx + , address :: !GYAddressBech32 + , value :: !KupoValue + , datumHash :: !(Maybe GYDatumHash) + , datumType :: !(Maybe KupoDatumType) + , scriptHash :: !(Maybe GYScriptHash) + , createdAt :: !KupoCreatedAt } deriving stock (Show, Eq, Ord, Generic) deriving (FromJSON) via CustomJSON '[FieldLabelModifier '[CamelToSnake]] KupoUtxo @@ -208,9 +241,9 @@ findScriptByHash :: GYScriptHash -> ClientM KupoScript fetchUtxosByPattern :: Pattern -> Bool -> Maybe Text -> Maybe Text -> ClientM (Headers '[Header "X-Most-Recent-Checkpoint" Word64] [KupoUtxo]) type KupoApi = - "datums" - :> Capture "datumHash" GYDatumHash - :> Get '[JSON] KupoDatum + "datums" + :> Capture "datumHash" GYDatumHash + :> Get '[JSON] KupoDatum :<|> "scripts" :> Capture "scriptHash" GYScriptHash :> Get '[JSON] KupoScript @@ -228,7 +261,8 @@ kupoLookupDatum :: KupoApiEnv -> GYLookupDatum kupoLookupDatum env dh = do KupoDatum md <- handleKupoError "LookupDatum" - <=< runKupoClient env $ findDatumByHash dh + <=< runKupoClient env + $ findDatumByHash dh pure md -- | Given a 'GYScriptHash' returns the corresponding 'GYScript' if found. @@ -236,7 +270,8 @@ kupoLookupScript :: KupoApiEnv -> GYScriptHash -> IO (Maybe GYAnyScript) kupoLookupScript env sh = do KupoScript ms <- handleKupoError "LookupScript" - <=< runKupoClient env $ findScriptByHash sh + <=< runKupoClient env + $ findScriptByHash sh pure ms -- | Find UTxOs at a given address. @@ -247,7 +282,7 @@ kupoUtxosAtAddress env addr mAssetClass = do addrUtxos <- handleKupoError locationIdent <=< runKupoClient env $ case extractedAssetClass of - Nothing -> commonRequestPart Nothing Nothing + Nothing -> commonRequestPart Nothing Nothing Just (mp, tn) -> commonRequestPart (Just mp) (Just tn) utxosFromList <$> traverse (transformUtxo env) (getResponse addrUtxos) where @@ -260,8 +295,8 @@ kupoUtxoAtTxOutRef env oref = do handleKupoError locationIdent <=< runKupoClient env $ fetchUtxosByPattern (Text.pack (show utxoIdx) <> "@" <> txId) True Nothing Nothing listToMaybe <$> traverse (transformUtxo env) (getResponse utxo) - where - locationIdent = "UtxoByRef" + where + locationIdent = "UtxoByRef" kupoUtxosAtPaymentCredential :: KupoApiEnv -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs kupoUtxosAtPaymentCredential env cred mAssetClass = do @@ -270,18 +305,18 @@ kupoUtxosAtPaymentCredential env cred mAssetClass = do credUtxos <- handleKupoError locationIdent <=< runKupoClient env $ case extractedAssetClass of - Nothing -> commonRequestPart Nothing Nothing + Nothing -> commonRequestPart Nothing Nothing Just (mp, tn) -> commonRequestPart (Just mp) (Just tn) utxosFromList <$> traverse (transformUtxo env) (getResponse credUtxos) - where - locationIdent = "PaymentCredentialUtxos" + where + locationIdent = "PaymentCredentialUtxos" transformUtxo :: KupoApiEnv -> KupoUtxo -> IO GYUTxO transformUtxo env KupoUtxo {..} = do let ref = txOutRefFromApiTxIdIx (txIdToApi transactionId) outputIndex dat <- case datumType of - Nothing -> pure GYOutDatumNone - Just Hash -> do + Nothing -> pure GYOutDatumNone + Just Hash -> do dh <- maybe (handleKupoAbsurdResponse locationIdent $ commonDatumHashError <> "'hash'") pure datumHash pure $ GYOutDatumHash dh Just Inline -> do @@ -291,7 +326,8 @@ transformUtxo env KupoUtxo {..} = do sc <- case scriptHash of Nothing -> pure Nothing Just sh -> kupoLookupScript env sh - pure $ GYUTxO + pure $ + GYUTxO { utxoRef = ref , utxoAddress = addressFromBech32 address , utxoValue = assets value <> valueFromLovelace (toInteger $ coins value) @@ -321,21 +357,20 @@ kupoQueryUtxo env = } kupoAwaitTxConfirmed :: KupoApiEnv -> GYAwaitTx -kupoAwaitTxConfirmed env p@GYAwaitTxParameters{..} txId = go 0 +kupoAwaitTxConfirmed env p@GYAwaitTxParameters {..} txId = go 0 where go attempt | attempt >= maxAttempts = throwIO $ GYAwaitTxException p | otherwise = do utxos <- handleKupoError locationIdent <=< runKupoClient env $ - fetchUtxosByPattern (Text.pack $ "*@" <> show txId) False Nothing Nothing -- We don't require for only @unspent@. Kupo with @--prune-utxo@ option would still keep spent UTxOs until their spent record is truly immutable (see Kupo docs for more details). + fetchUtxosByPattern (Text.pack $ "*@" <> show txId) False Nothing Nothing -- We don't require for only @unspent@. Kupo with @--prune-utxo@ option would still keep spent UTxOs until their spent record is truly immutable (see Kupo docs for more details). case listToMaybe (getResponse utxos) of Nothing -> threadDelay checkInterval >> go (attempt + 1) - Just u -> do - let slotsToWait = 3 * confirmations * 20 -- Ouroboros Praos guarantees that there are at least @k@ blocks in a window of @3k / f@ slots where @f@ is the active slot coefficient, which is @0.05@ for Mainnet, Preprod & Preview. + Just u -> do + let slotsToWait = 3 * confirmations * 20 -- Ouroboros Praos guarantees that there are at least @k@ blocks in a window of @3k / f@ slots where @f@ is the active slot coefficient, which is @0.05@ for Mainnet, Preprod & Preview. case (lookupResponseHeader utxos :: ResponseHeader "X-Most-Recent-Checkpoint" Word64) of Header slotOfCurrentBlock -> unless (slotNo (createdAt u) + slotsToWait <= slotOfCurrentBlock) $ threadDelay checkInterval >> go (attempt + 1) _ -> handleKupoAbsurdResponse locationIdent "Header 'X-Most-Recent-Checkpoint' isn't seen in response" - - where - locationIdent = "AwaitTx" + where + locationIdent = "AwaitTx" diff --git a/src/GeniusYield/Providers/LiteChainIndex.hs b/src/GeniusYield/Providers/LiteChainIndex.hs index 1f692953..17ecf4cf 100644 --- a/src/GeniusYield/Providers/LiteChainIndex.hs +++ b/src/GeniusYield/Providers/LiteChainIndex.hs @@ -1,78 +1,81 @@ -{-| +{- | Module : GeniusYield.Providers.LiteChainIndex Description : Lite-chain index. In memory chain index. Used in tests Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Providers.LiteChainIndex ( - LCIClient, - withLCIClient, - newLCIClient, - closeLCIClient, - lciWaitUntilSlot, - lciLookupDatum, - lciGetCurrentSlot, - lciStats, + LCIClient, + withLCIClient, + newLCIClient, + closeLCIClient, + lciWaitUntilSlot, + lciLookupDatum, + lciGetCurrentSlot, + lciStats, ) where -import GeniusYield.Imports -import GeniusYield.Types +import GeniusYield.Imports +import GeniusYield.Types -import qualified Cardano.Api as Api -import qualified Cardano.Api.ChainSync.Client as Api.Sync -import qualified Control.Concurrent.Async as Async -import qualified Control.Concurrent.STM as STM -import qualified Data.Map.Strict as Map +import Cardano.Api qualified as Api +import Cardano.Api.ChainSync.Client qualified as Api.Sync +import Control.Concurrent.Async qualified as Async +import Control.Concurrent.STM qualified as STM +import Data.Map.Strict qualified as Map -- | A very simple chain index client, which only maintains a datum hashes. --- -data LCIClient = LCIClient - (Async.Async ()) - (STM.TVar Api.SlotNo) - (STM.TVar (Map (Api.Hash Api.ScriptData) Api.HashableScriptData)) - -withLCIClient - :: Api.LocalNodeConnectInfo - -> [Api.ChainPoint] -- ^ resume points - -> (LCIClient -> IO r) - -> IO r +data LCIClient + = LCIClient + (Async.Async ()) + (STM.TVar Api.SlotNo) + (STM.TVar (Map (Api.Hash Api.ScriptData) Api.HashableScriptData)) + +withLCIClient :: + Api.LocalNodeConnectInfo -> + -- | resume points + [Api.ChainPoint] -> + (LCIClient -> IO r) -> + IO r withLCIClient info resumePoints kont = do - slotVar <- STM.newTVarIO $ Api.SlotNo 0 - dataVar <- STM.newTVarIO Map.empty + slotVar <- STM.newTVarIO $ Api.SlotNo 0 + dataVar <- STM.newTVarIO Map.empty - let cb = chainSyncCallback slotVar dataVar + let cb = chainSyncCallback slotVar dataVar - withChainSync info resumePoints cb $ \a -> kont $ LCIClient + withChainSync info resumePoints cb $ \a -> + kont $ + LCIClient a slotVar dataVar --- | Create new 'LCIClient'. --- --- Use 'withLCIClient' if possible. -newLCIClient - :: Api.LocalNodeConnectInfo - -> [Api.ChainPoint] -- ^ resume points - -> IO LCIClient +{- | Create new 'LCIClient'. + +Use 'withLCIClient' if possible. +-} +newLCIClient :: + Api.LocalNodeConnectInfo -> + -- | resume points + [Api.ChainPoint] -> + IO LCIClient newLCIClient info resumePoints = do - slotVar <- STM.newTVarIO $ Api.SlotNo 0 - dataVar <- STM.newTVarIO Map.empty + slotVar <- STM.newTVarIO $ Api.SlotNo 0 + dataVar <- STM.newTVarIO Map.empty - let cb = chainSyncCallback slotVar dataVar + let cb = chainSyncCallback slotVar dataVar - a <- newChainSync info resumePoints cb - return $ LCIClient a slotVar dataVar + a <- newChainSync info resumePoints cb + return $ LCIClient a slotVar dataVar chainSyncCallback :: STM.TVar Api.SlotNo -> STM.TVar (Map (Api.Hash Api.ScriptData) Api.HashableScriptData) -> ChainSyncCallback chainSyncCallback slotVar dataVar (RollForward block@(Api.BlockInMode Api.ConwayEra (Api.Block (Api.BlockHeader slot _ _) _txs)) _tip) = - STM.atomically $ do - STM.writeTVar slotVar slot - STM.modifyTVar' dataVar $ \m -> - foldl' (\m' sd -> Map.insert (Api.hashScriptDataBytes sd) sd m') m (blockDatums block) - + STM.atomically $ do + STM.writeTVar slotVar slot + STM.modifyTVar' dataVar $ \m -> + foldl' (\m' sd -> Map.insert (Api.hashScriptDataBytes sd) sd m') m (blockDatums block) chainSyncCallback _ _ _ = return () -- | Close (destroy) 'LCIClient'. @@ -82,110 +85,114 @@ closeLCIClient (LCIClient a _ _) = Async.cancel a -- | Wait until 'LCIClient' has processed a given slot. lciWaitUntilSlot :: LCIClient -> GYSlot -> IO GYSlot lciWaitUntilSlot (LCIClient _ slotVar _) (slotToApi -> slot) = STM.atomically $ do - slot' <- STM.readTVar slotVar - unless (slot' >= slot) STM.retry - return (slotFromApi slot') + slot' <- STM.readTVar slotVar + unless (slot' >= slot) STM.retry + return (slotFromApi slot') lookupApiDatum :: LCIClient -> Api.Hash Api.ScriptData -> IO (Maybe Api.HashableScriptData) lookupApiDatum (LCIClient _ _ dataVar) h = do - m <- STM.readTVarIO dataVar - return $ Map.lookup h m + m <- STM.readTVarIO dataVar + return $ Map.lookup h m lciLookupDatum :: LCIClient -> GYLookupDatum lciLookupDatum c dh = fmap datumFromApi' <$> lookupApiDatum c (datumHashToApi dh) --- | This is not good 'GeniusYield.Types.Providers.gyGetCurrentSlot' provider as it might lag --- plenty behind the current slot of local node. +{- | This is not good 'GeniusYield.Types.Providers.gyGetCurrentSlot' provider as it might lag +plenty behind the current slot of local node. +-} lciGetCurrentSlot :: LCIClient -> IO GYSlot lciGetCurrentSlot (LCIClient _ slotVar _) = slotFromApi <$> STM.readTVarIO slotVar -- | Return statistics of 'LCIClient': currently processed slot and number of hashes known. lciStats :: LCIClient -> IO (GYSlot, Int) lciStats (LCIClient _ slotVar dataVar) = STM.atomically $ do - slot <- STM.readTVar slotVar - m <- STM.readTVar dataVar - return (slotFromApi slot, Map.size m) + slot <- STM.readTVar slotVar + m <- STM.readTVar dataVar + return (slotFromApi slot, Map.size m) ------------------------------------------------------------------------------- -- simplified Cardano.Protocol.Socket.Client ------------------------------------------------------------------------------- data ChainSyncEvent - = Resume !Api.ChainPoint - | RollForward !Api.BlockInMode !Api.ChainTip - | RollBackward !Api.ChainPoint !Api.ChainTip + = Resume !Api.ChainPoint + | RollForward !Api.BlockInMode !Api.ChainTip + | RollBackward !Api.ChainPoint !Api.ChainTip type ChainSyncCallback = ChainSyncEvent -> IO () -withChainSync - :: Api.LocalNodeConnectInfo - -> [Api.ChainPoint] - -> ChainSyncCallback - -> (Async.Async () -> IO r) - -> IO r +withChainSync :: + Api.LocalNodeConnectInfo -> + [Api.ChainPoint] -> + ChainSyncCallback -> + (Async.Async () -> IO r) -> + IO r withChainSync info resumePoints callback = Async.withAsync (Api.connectToLocalNode info localNodeClientProtocols) where localNodeClientProtocols :: Api.LocalNodeClientProtocolsInMode - localNodeClientProtocols = Api.LocalNodeClientProtocols - { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback + localNodeClientProtocols = + Api.LocalNodeClientProtocols + { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback , localTxSubmissionClient = Nothing - , localStateQueryClient = Nothing + , localStateQueryClient = Nothing , localTxMonitoringClient = Nothing } -newChainSync - :: Api.LocalNodeConnectInfo - -> [Api.ChainPoint] - -> ChainSyncCallback - -> IO (Async.Async ()) +newChainSync :: + Api.LocalNodeConnectInfo -> + [Api.ChainPoint] -> + ChainSyncCallback -> + IO (Async.Async ()) newChainSync info resumePoints callback = - Async.async (Api.connectToLocalNode info localNodeClientProtocols) + Async.async (Api.connectToLocalNode info localNodeClientProtocols) where localNodeClientProtocols :: Api.LocalNodeClientProtocolsInMode - localNodeClientProtocols = Api.LocalNodeClientProtocols - { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback + localNodeClientProtocols = + Api.LocalNodeClientProtocols + { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback , localTxSubmissionClient = Nothing - , localStateQueryClient = Nothing + , localStateQueryClient = Nothing , localTxMonitoringClient = Nothing } -chainSyncClient - :: [Api.ChainPoint] - -> ChainSyncCallback - -> Api.ChainSyncClient Api.BlockInMode Api.ChainPoint Api.ChainTip IO () -chainSyncClient [] cb = chainSyncClient [Api.ChainPointAtGenesis] cb +chainSyncClient :: + [Api.ChainPoint] -> + ChainSyncCallback -> + Api.ChainSyncClient Api.BlockInMode Api.ChainPoint Api.ChainTip IO () +chainSyncClient [] cb = chainSyncClient [Api.ChainPointAtGenesis] cb chainSyncClient resumePoints cb = - Api.ChainSyncClient $ pure initialise - where - initialise = Api.Sync.SendMsgFindIntersect resumePoints $ Api.Sync.ClientStIntersect - { Api.Sync.recvMsgIntersectFound = \ point _tip -> Api.ChainSyncClient $ do + Api.ChainSyncClient $ pure initialise + where + initialise = + Api.Sync.SendMsgFindIntersect resumePoints $ + Api.Sync.ClientStIntersect + { Api.Sync.recvMsgIntersectFound = \point _tip -> Api.ChainSyncClient $ do cb (Resume point) pure requestNext - - , Api.Sync.recvMsgIntersectNotFound = \ _tip -> + , Api.Sync.recvMsgIntersectNotFound = \_tip -> Api.ChainSyncClient $ pure requestNext } - requestNext :: Api.Sync.ClientStIdle Api.BlockInMode Api.ChainPoint Api.ChainTip IO () - requestNext = Api.Sync.SendMsgRequestNext (pure ()) handleNext - - handleNext = Api.Sync.ClientStNext - { Api.Sync.recvMsgRollForward = \block tip -> Api.ChainSyncClient $ do - cb (RollForward block tip) - pure requestNext - - , Api.Sync.recvMsgRollBackward = \point tip -> Api.ChainSyncClient $ do - cb (RollBackward point tip) - pure requestNext - - } + requestNext :: Api.Sync.ClientStIdle Api.BlockInMode Api.ChainPoint Api.ChainTip IO () + requestNext = Api.Sync.SendMsgRequestNext (pure ()) handleNext + + handleNext = + Api.Sync.ClientStNext + { Api.Sync.recvMsgRollForward = \block tip -> Api.ChainSyncClient $ do + cb (RollForward block tip) + pure requestNext + , Api.Sync.recvMsgRollBackward = \point tip -> Api.ChainSyncClient $ do + cb (RollBackward point tip) + pure requestNext + } ------------------------------------------------------------------------------- -- Utilities ------------------------------------------------------------------------------- blockDatums :: Api.BlockInMode -> [Api.HashableScriptData] -blockDatums (Api.BlockInMode _ block) = goBlock block where +blockDatums (Api.BlockInMode _ block) = goBlock block + where goBlock :: Api.Block era -> [Api.HashableScriptData] goBlock (Api.Block _header txs) = concatMap goTx txs @@ -199,7 +206,7 @@ blockDatums (Api.BlockInMode _ block) = goBlock block where goTxOut (Api.TxOut _addr _value datum _) = goDatum datum goDatum :: Api.TxOutDatum Api.CtxTx era -> [Api.HashableScriptData] - goDatum Api.TxOutDatumNone = [] - goDatum (Api.TxOutDatumInTx _ sd) = [sd] - goDatum (Api.TxOutDatumHash _ _h) = [] + goDatum Api.TxOutDatumNone = [] + goDatum (Api.TxOutDatumInTx _ sd) = [sd] + goDatum (Api.TxOutDatumHash _ _h) = [] goDatum (Api.TxOutDatumInline _ sd) = [sd] diff --git a/src/GeniusYield/Providers/Maestro.hs b/src/GeniusYield/Providers/Maestro.hs index 11f458d6..d67925a5 100644 --- a/src/GeniusYield/Providers/Maestro.hs +++ b/src/GeniusYield/Providers/Maestro.hs @@ -1,63 +1,64 @@ -{-| +{- | Module : GeniusYield.Providers.Maestro Description : Providers using the Maestro blockchain API. Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Providers.Maestro - ( networkIdToMaestroEnv - , maestroSubmitTx - , maestroAwaitTxConfirmed - , maestroGetSlotOfCurrentBlock - , utxoFromMaestro - , maestroQueryUtxo - , maestroProtocolParams - , maestroStakePools - , maestroSystemStart - , maestroEraHistory - , maestroLookupDatum - , maestroUtxosAtAddressesWithDatums - , maestroUtxosAtPaymentCredentialsWithDatums - , maestroStakeAddressInfo - ) where - -import qualified Cardano.Api as Api -import qualified Cardano.Api.Ledger as Api.L -import qualified Cardano.Api.Ledger as Ledger -import qualified Cardano.Api.Shelley as Api.S -import qualified Cardano.Ledger.Alonzo.PParams as Ledger -import Cardano.Ledger.Conway.PParams (ConwayPParams (..), - THKD (..)) -import qualified Cardano.Ledger.Plutus as Ledger -import qualified Cardano.Slotting.Slot as CSlot -import qualified Cardano.Slotting.Time as CTime -import Control.Concurrent (threadDelay) -import Control.Exception (try) -import Control.Monad ((<=<)) -import qualified Data.Aeson as Aeson -import Data.Default (def) -import Data.Either.Combinators (maybeToRight) -import Data.Int (Int64) -import qualified Data.Map.Strict as M -import Data.Maybe (fromJust) -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Time as Time -import GeniusYield.Imports -import GeniusYield.Providers.Common -import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) -import GHC.Natural (wordToNatural) -import qualified Maestro.Client.V1 as Maestro -import qualified Maestro.Client.V1.Accounts as Maestro -import qualified Maestro.Types.V1 as Maestro -import qualified Ouroboros.Consensus.HardFork.History as Ouroboros -import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (eraGenesisWin)) -import qualified PlutusTx.Builtins as Plutus -import qualified Web.HttpApiData as Web +module GeniusYield.Providers.Maestro ( + networkIdToMaestroEnv, + maestroSubmitTx, + maestroAwaitTxConfirmed, + maestroGetSlotOfCurrentBlock, + utxoFromMaestro, + maestroQueryUtxo, + maestroProtocolParams, + maestroStakePools, + maestroSystemStart, + maestroEraHistory, + maestroLookupDatum, + maestroUtxosAtAddressesWithDatums, + maestroUtxosAtPaymentCredentialsWithDatums, + maestroStakeAddressInfo, +) where + +import Cardano.Api qualified as Api +import Cardano.Api.Ledger qualified as Api.L +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Ledger.Alonzo.PParams qualified as Ledger +import Cardano.Ledger.Conway.PParams ( + ConwayPParams (..), + THKD (..), + ) +import Cardano.Ledger.Plutus qualified as Ledger +import Cardano.Slotting.Slot qualified as CSlot +import Cardano.Slotting.Time qualified as CTime +import Control.Concurrent (threadDelay) +import Control.Exception (try) +import Control.Monad ((<=<)) +import Data.Aeson qualified as Aeson +import Data.Default (def) +import Data.Either.Combinators (maybeToRight) +import Data.Int (Int64) +import Data.Map.Strict qualified as M +import Data.Maybe (fromJust) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time qualified as Time +import GHC.Natural (wordToNatural) +import GeniusYield.Imports +import GeniusYield.Providers.Common +import GeniusYield.Types +import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) +import Maestro.Client.V1 qualified as Maestro +import Maestro.Client.V1.Accounts qualified as Maestro +import Maestro.Types.V1 qualified as Maestro +import Ouroboros.Consensus.HardFork.History qualified as Ouroboros +import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (eraGenesisWin)) +import PlutusTx.Builtins qualified as Plutus +import Web.HttpApiData qualified as Web -- | Convert our representation of Network ID to Maestro's. networkIdToMaestroEnv :: Text -> GYNetworkId -> IO (Maestro.MaestroEnv 'Maestro.V1) @@ -65,20 +66,20 @@ networkIdToMaestroEnv key nid = Maestro.mkMaestroEnv @'Maestro.V1 key (fromMaybe -- | Exceptions. data MaestroProviderException - = MspvApiError !Text !Maestro.MaestroError - -- ^ Error from the Maestro API. - | MspvDeserializeFailure !Text !SomeDeserializeError - -- ^ This error should never actually happen (unless there's a bug). - | MspvMultiUtxoPerRef !GYTxOutRef - -- ^ The API returned several utxos for a single TxOutRef. - | MspvIncorrectEraHistoryLength ![Maestro.EraSummary] - -- ^ The API returned an unexpected number of era summaries. + = -- | Error from the Maestro API. + MspvApiError !Text !Maestro.MaestroError + | -- | This error should never actually happen (unless there's a bug). + MspvDeserializeFailure !Text !SomeDeserializeError + | -- | The API returned several utxos for a single TxOutRef. + MspvMultiUtxoPerRef !GYTxOutRef + | -- | The API returned an unexpected number of era summaries. + MspvIncorrectEraHistoryLength ![Maestro.EraSummary] deriving stock (Eq, Show) deriving anyclass (Exception) throwMspvApiError :: Text -> Maestro.MaestroError -> IO a throwMspvApiError locationInfo = - throwIO . MspvApiError locationInfo . silenceHeadersMaestroClientError + throwIO . MspvApiError locationInfo . silenceHeadersMaestroClientError -- | Utility function to handle Maestro errors, which also removes header (if present) so as to conceal API key. handleMaestroError :: Text -> Either Maestro.MaestroError a -> IO a @@ -87,7 +88,7 @@ handleMaestroError locationInfo = either (throwMspvApiError locationInfo) pure -- | Remove headers (if `MaestroError` contains `ClientError`). silenceHeadersMaestroClientError :: Maestro.MaestroError -> Maestro.MaestroError silenceHeadersMaestroClientError (Maestro.ServantClientError e) = Maestro.ServantClientError $ silenceHeadersClientError e -silenceHeadersMaestroClientError other = other +silenceHeadersMaestroClientError other = other ------------------------------------------------------------------------------- -- Submit @@ -100,7 +101,8 @@ maestroSubmitTx useTurboSubmit env tx = do either (throwIO . MspvDeserializeFailure "SubmitTx" . DeserializeErrorHex . Text.pack) pure - $ txIdFromHexE $ Text.unpack txId + $ txIdFromHexE + $ Text.unpack txId where handleMaestroSubmitError :: Either Maestro.MaestroError a -> IO a handleMaestroSubmitError = either (throwIO . SubmitTxException . Text.pack . show . silenceHeadersMaestroClientError) pure @@ -111,52 +113,62 @@ maestroSubmitTx useTurboSubmit env tx = do -- | Awaits for the confirmation of a given 'GYTxId' maestroAwaitTxConfirmed :: Maestro.MaestroEnv 'Maestro.V1 -> GYAwaitTx -maestroAwaitTxConfirmed env p@GYAwaitTxParameters{..} txId = mspvAwaitTx 0 +maestroAwaitTxConfirmed env p@GYAwaitTxParameters {..} txId = mspvAwaitTx 0 where mspvAwaitTx :: Int -> IO () mspvAwaitTx attempt | maxAttempts <= attempt = throwIO $ GYAwaitTxException p mspvAwaitTx attempt = do - eTxInfo <- maestroQueryTx env txId - case eTxInfo of - Left Maestro.MaestroNotFound -> threadDelay checkInterval >> - mspvAwaitTx (attempt + 1) - Left err -> throwMspvApiError "AwaitTx" err - Right txInfo -> msvpAwaitBlock attempt $ - Maestro.txDetailsBlockHash $ - Maestro.getTimestampedData txInfo + eTxInfo <- maestroQueryTx env txId + case eTxInfo of + Left Maestro.MaestroNotFound -> + threadDelay checkInterval + >> mspvAwaitTx (attempt + 1) + Left err -> throwMspvApiError "AwaitTx" err + Right txInfo -> + msvpAwaitBlock attempt $ + Maestro.txDetailsBlockHash $ + Maestro.getTimestampedData txInfo msvpAwaitBlock :: Int -> Maestro.BlockHash -> IO () msvpAwaitBlock attempt _ | maxAttempts <= attempt = throwIO $ GYAwaitTxException p msvpAwaitBlock attempt blockHash = do - eBlockInfo <- maestroQueryBlock env blockHash - case eBlockInfo of - Left Maestro.MaestroNotFound -> threadDelay checkInterval >> - msvpAwaitBlock (attempt + 1) blockHash - Left err -> throwMspvApiError "AwaitBlock" err - - Right (Maestro.getTimestampedData -> blockInfo) | attempt + 1 == maxAttempts -> - when (toInteger (Maestro.blockDetailsConfirmations blockInfo) - < - toInteger confirmations) $ throwIO $ GYAwaitTxException p - - Right (Maestro.getTimestampedData -> blockInfo) -> - when (toInteger (Maestro.blockDetailsConfirmations blockInfo) - < - toInteger confirmations) $ - threadDelay checkInterval >> msvpAwaitBlock (attempt + 1) blockHash - -maestroQueryBlock - :: Maestro.MaestroEnv 'Maestro.V1 - -> Maestro.BlockHash - -> IO (Either Maestro.MaestroError Maestro.TimestampedBlockDetails) + eBlockInfo <- maestroQueryBlock env blockHash + case eBlockInfo of + Left Maestro.MaestroNotFound -> + threadDelay checkInterval + >> msvpAwaitBlock (attempt + 1) blockHash + Left err -> throwMspvApiError "AwaitBlock" err + Right (Maestro.getTimestampedData -> blockInfo) + | attempt + 1 == maxAttempts -> + when + ( toInteger (Maestro.blockDetailsConfirmations blockInfo) + < toInteger confirmations + ) + $ throwIO + $ GYAwaitTxException p + Right (Maestro.getTimestampedData -> blockInfo) -> + when + ( toInteger (Maestro.blockDetailsConfirmations blockInfo) + < toInteger confirmations + ) + $ threadDelay checkInterval >> msvpAwaitBlock (attempt + 1) blockHash + +maestroQueryBlock :: + Maestro.MaestroEnv 'Maestro.V1 -> + Maestro.BlockHash -> + IO (Either Maestro.MaestroError Maestro.TimestampedBlockDetails) maestroQueryBlock env = try . Maestro.blockDetailsByHash env -maestroQueryTx - :: Maestro.MaestroEnv 'Maestro.V1 - -> GYTxId - -> IO (Either Maestro.MaestroError Maestro.TimestampedTxDetails) -maestroQueryTx env = try . Maestro.txInfo env . Maestro.TxHash . - Api.serialiseToRawBytesHexText . txIdToApi +maestroQueryTx :: + Maestro.MaestroEnv 'Maestro.V1 -> + GYTxId -> + IO (Either Maestro.MaestroError Maestro.TimestampedTxDetails) +maestroQueryTx env = + try + . Maestro.txInfo env + . Maestro.TxHash + . Api.serialiseToRawBytesHexText + . txIdToApi ------------------------------------------------------------------------------- -- Slot actions @@ -181,12 +193,12 @@ _datumFromMaestroJSON datumJson = datumFromPlutus' <$> fromJson @Plutus.BuiltinD -- | Convert datum present in UTxO to our GY type, `GYOutDatum`. outDatumFromMaestro :: Maybe Maestro.DatumOption -> Either SomeDeserializeError GYOutDatum -outDatumFromMaestro Nothing = Right GYOutDatumNone +outDatumFromMaestro Nothing = Right GYOutDatumNone outDatumFromMaestro (Just Maestro.DatumOption {..}) = case datumOptionType of Maestro.Hash -> GYOutDatumHash <$> datumHashFromMaestro datumOptionHash Maestro.Inline -> case datumOptionBytes of - Nothing -> Left $ DeserializeErrorImpossibleBranch "Datum type is inline but datum bytestring is missing" + Nothing -> Left $ DeserializeErrorImpossibleBranch "Datum type is inline but datum bytestring is missing" Just db -> GYOutDatumInline <$> datumFromCBOR db -- | Convert Maestro's asset class to our GY type. @@ -203,21 +215,21 @@ valueFromMaestro Maestro.Asset {..} = do -- | Convert Maestro's script to our GY type. scriptFromMaestro :: Maestro.Script -> Either SomeDeserializeError (Maybe GYAnyScript) scriptFromMaestro Maestro.Script {..} = case scriptType of - Maestro.Native -> case scriptJson of + Maestro.Native -> case scriptJson of Nothing -> Left $ DeserializeErrorImpossibleBranch "UTxO has native script but no script JSON is present" Just sj -> pure $ GYSimpleScript <$> simpleScriptFromJSON sj Maestro.PlutusV1 -> case scriptBytes of Nothing -> Left $ DeserializeErrorImpossibleBranch "UTxO has PlutusV1 script but still no script bytes are present" - Just sb -> pure $ GYPlutusScript <$> scriptFromCBOR @'PlutusV1 sb + Just sb -> pure $ GYPlutusScript <$> scriptFromCBOR @'PlutusV1 sb Maestro.PlutusV2 -> case scriptBytes of Nothing -> Left $ DeserializeErrorImpossibleBranch "UTxO has PlutusV2 script but still no script bytes are present" - Just sb -> pure $ GYPlutusScript <$> scriptFromCBOR @'PlutusV2 sb + Just sb -> pure $ GYPlutusScript <$> scriptFromCBOR @'PlutusV2 sb Maestro.PlutusV3 -> case scriptBytes of Nothing -> Left $ DeserializeErrorImpossibleBranch "UTxO has PlutusV3 script but still no script bytes are present" - Just sb -> pure $ GYPlutusScript <$> scriptFromCBOR @'PlutusV3 sb + Just sb -> pure $ GYPlutusScript <$> scriptFromCBOR @'PlutusV3 sb -- | Convert Maestro's UTxO to our GY type. -utxoFromMaestro :: Maestro.IsUtxo a => a -> Either SomeDeserializeError GYUTxO +utxoFromMaestro :: (Maestro.IsUtxo a) => a -> Either SomeDeserializeError GYUTxO utxoFromMaestro utxo = do ref <- first DeserializeErrorHex . Web.parseUrlPiece $ Web.toUrlPiece (Maestro.getTxHash utxo) <> "#" <> Web.toUrlPiece (Maestro.getIndex utxo) addr <- maybeToRight DeserializeErrorAddress $ addressFromTextMaybe $ coerce $ Maestro.getAddress utxo @@ -226,15 +238,15 @@ utxoFromMaestro utxo = do s <- maybe (pure Nothing) scriptFromMaestro $ Maestro.getReferenceScript utxo pure $ GYUTxO - { utxoRef = ref - , utxoAddress = addr - , utxoValue = mconcat vs - , utxoOutDatum = d + { utxoRef = ref + , utxoAddress = addr + , utxoValue = mconcat vs + , utxoOutDatum = d , utxoRefScript = s } -- | Convert Maestro's UTxO (with datum resolved) to our GY types. -utxoFromMaestroWithDatum :: Maestro.IsUtxo a => a -> Either SomeDeserializeError (GYUTxO, Maybe GYDatum) +utxoFromMaestroWithDatum :: (Maestro.IsUtxo a) => a -> Either SomeDeserializeError (GYUTxO, Maybe GYDatum) utxoFromMaestroWithDatum u = do gyUtxo <- utxoFromMaestro u case utxoOutDatum gyUtxo of @@ -359,13 +371,13 @@ maestroRefsAtAddress env addr = do -- Here one would not get `MaestroNotFound` error. mTxRefs <- handleMaestroError locationIdent <=< try $ Maestro.allPages (Maestro.getRefsAtAddress env $ coerce (addressToText addr)) either - (throwIO . MspvDeserializeFailure locationIdent . DeserializeErrorHex) - pure - $ traverse - (\Maestro.OutputReferenceObject {..} -> - Web.parseUrlPiece $ Web.toUrlPiece outputReferenceObjectTxHash <> "#" <> Web.toUrlPiece outputReferenceObjectIndex - ) - mTxRefs + (throwIO . MspvDeserializeFailure locationIdent . DeserializeErrorHex) + pure + $ traverse + ( \Maestro.OutputReferenceObject {..} -> + Web.parseUrlPiece $ Web.toUrlPiece outputReferenceObjectTxHash <> "#" <> Web.toUrlPiece outputReferenceObjectIndex + ) + mTxRefs where locationIdent = "RefsAtAddress" @@ -374,8 +386,8 @@ maestroUtxoAtTxOutRef :: Maestro.MaestroEnv 'Maestro.V1 -> GYTxOutRef -> IO (May maestroUtxoAtTxOutRef env ref = do res <- maestroUtxosAtTxOutRefs' env [ref] case res of - [] -> pure Nothing - [x] -> pure $ Just x + [] -> pure Nothing + [x] -> pure $ Just x -- This shouldn't happen. _anyOtherFailure -> throwIO $ MspvMultiUtxoPerRef ref @@ -386,7 +398,7 @@ maestroUtxosAtTxOutRefs env = fmap utxosFromList . maestroUtxosAtTxOutRefs' env toMaestroOutputReference :: GYTxOutRef -> Maestro.OutputReference toMaestroOutputReference oref = let (txId, txIx) = txOutRefToTuple' oref - in Maestro.OutputReference (coerce txId) (coerce $ wordToNatural txIx) + in Maestro.OutputReference (coerce txId) (coerce $ wordToNatural txIx) -- | Query UTxO in case of multiple output references. maestroUtxosAtTxOutRefs' :: Maestro.MaestroEnv 'Maestro.V1 -> [GYTxOutRef] -> IO [GYUTxO] @@ -396,9 +408,9 @@ maestroUtxosAtTxOutRefs' env refs = do res <- handler <=< try $ Maestro.allPages (flip (Maestro.outputsByReferences env (Just False) (Just False)) refs') either - (throwIO . MspvDeserializeFailure locationIdent) - pure - $ traverse utxoFromMaestro res + (throwIO . MspvDeserializeFailure locationIdent) + pure + $ traverse utxoFromMaestro res where -- This particular error is fine in this case, we can just return @mempty@. handler (Left Maestro.MaestroNotFound) = pure [] @@ -414,9 +426,9 @@ maestroUtxosAtTxOutRefsWithDatums env refs = do res <- handler <=< try $ Maestro.allPages (flip (Maestro.outputsByReferences env (Just True) (Just False)) refs') either - (throwIO . MspvDeserializeFailure locationIdent) - pure - $ traverse utxoFromMaestroWithDatum res + (throwIO . MspvDeserializeFailure locationIdent) + pure + $ traverse utxoFromMaestroWithDatum res where -- This particular error is fine in this case, we can just return @mempty@. handler (Left Maestro.MaestroNotFound) = pure [] @@ -426,20 +438,21 @@ maestroUtxosAtTxOutRefsWithDatums env refs = do -- | Definition of 'GYQueryUTxO' for the Maestro provider. maestroQueryUtxo :: Maestro.MaestroEnv 'Maestro.V1 -> GYQueryUTxO -maestroQueryUtxo env = GYQueryUTxO - { gyQueryUtxosAtAddresses' = maestroUtxosAtAddresses env - , gyQueryUtxosAtAddress' = maestroUtxosAtAddress env - , gyQueryUtxosAtAddressWithDatums' = Just $ maestroUtxosAtAddressWithDatums env - , gyQueryUtxosAtTxOutRefs' = maestroUtxosAtTxOutRefs env - , gyQueryUtxosAtTxOutRefsWithDatums' = Just $ maestroUtxosAtTxOutRefsWithDatums env - , gyQueryUtxoAtTxOutRef' = maestroUtxoAtTxOutRef env - , gyQueryUtxoRefsAtAddress' = maestroRefsAtAddress env - , gyQueryUtxosAtAddressesWithDatums' = Just $ maestroUtxosAtAddressesWithDatums env - , gyQueryUtxosAtPaymentCredential' = maestroUtxosAtPaymentCredential env - , gyQueryUtxosAtPaymentCredWithDatums' = Just $ maestroUtxosAtPaymentCredentialWithDatums env - , gyQueryUtxosAtPaymentCredentials' = maestroUtxosAtPaymentCredentials env - , gyQueryUtxosAtPaymentCredsWithDatums' = Just $ maestroUtxosAtPaymentCredentialsWithDatums env - } +maestroQueryUtxo env = + GYQueryUTxO + { gyQueryUtxosAtAddresses' = maestroUtxosAtAddresses env + , gyQueryUtxosAtAddress' = maestroUtxosAtAddress env + , gyQueryUtxosAtAddressWithDatums' = Just $ maestroUtxosAtAddressWithDatums env + , gyQueryUtxosAtTxOutRefs' = maestroUtxosAtTxOutRefs env + , gyQueryUtxosAtTxOutRefsWithDatums' = Just $ maestroUtxosAtTxOutRefsWithDatums env + , gyQueryUtxoAtTxOutRef' = maestroUtxoAtTxOutRef env + , gyQueryUtxoRefsAtAddress' = maestroRefsAtAddress env + , gyQueryUtxosAtAddressesWithDatums' = Just $ maestroUtxosAtAddressesWithDatums env + , gyQueryUtxosAtPaymentCredential' = maestroUtxosAtPaymentCredential env + , gyQueryUtxosAtPaymentCredWithDatums' = Just $ maestroUtxosAtPaymentCredentialWithDatums env + , gyQueryUtxosAtPaymentCredentials' = maestroUtxosAtPaymentCredentials env + , gyQueryUtxosAtPaymentCredsWithDatums' = Just $ maestroUtxosAtPaymentCredentialsWithDatums env + } ------------------------------------------------------------------------------- -- Parameters @@ -449,63 +462,79 @@ maestroQueryUtxo env = GYQueryUTxO maestroProtocolParams :: GYNetworkId -> Maestro.MaestroEnv 'Maestro.V1 -> IO ApiProtocolParameters maestroProtocolParams nid env = do Maestro.ProtocolParameters {..} <- handleMaestroError "ProtocolParams" <=< try $ Maestro.getTimestampedData <$> Maestro.getProtocolParameters env - pure $ Ledger.PParams $ populateMissingProtocolParameters nid $ - ConwayPParams - { cppMinFeeA = THKD $ Ledger.Coin $ toInteger protocolParametersMinFeeCoefficient - , cppMinFeeB = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersMinFeeConstant - , cppMaxBBSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxBlockBodySize - , cppMaxTxSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxTransactionSize - , cppMaxBHSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxBlockHeaderSize - , cppKeyDeposit = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersStakeCredentialDeposit - , cppPoolDeposit = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersStakePoolDeposit - , cppEMax = THKD $ Ledger.EpochInterval . fromIntegral - $ Maestro.unEpochNo protocolParametersStakePoolRetirementEpochBound - , cppNOpt = THKD $ fromIntegral protocolParametersDesiredNumberOfStakePools - , cppA0 = THKD $ fromMaybe (error (errPath <> "Pool influence received from Maestro is out of bounds")) $ Ledger.boundRational $ Maestro.unMaestroRational protocolParametersStakePoolPledgeInfluence - , cppRho = THKD $ fromMaybe (error (errPath <> "Monetory expansion parameter received from Maestro is out of bounds")) $ Ledger.boundRational $ Maestro.unMaestroRational protocolParametersMonetaryExpansion - , cppTau = THKD $ fromMaybe (error (errPath <> "Treasury expansion parameter received from Maestro is out of bounds")) $ Ledger.boundRational $ Maestro.unMaestroRational protocolParametersTreasuryExpansion - , cppProtocolVersion = Ledger.ProtVer { - Ledger.pvMajor = Ledger.mkVersion (Maestro.protocolVersionMajor protocolParametersVersion) & fromMaybe (error (errPath <> "Major version received from Maestro is out of bounds")), - Ledger.pvMinor = Maestro.protocolVersionMinor protocolParametersVersion - } - , cppMinPoolCost = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersMinStakePoolCost - , cppCoinsPerUTxOByte = THKD $ Api.L.CoinPerByte $ Ledger.Coin $ toInteger protocolParametersMinUtxoDepositCoefficient - , cppCostModels = THKD $ Ledger.mkCostModels $ M.fromList - [ ( Ledger.PlutusV1 - , either (error (errPath <> "Couldn't build PlutusV1 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV1 $ coerce @_ @[Int64] (Maestro.costModelsPlutusV1 protocolParametersPlutusCostModels) - ) - , ( Ledger.PlutusV2 - , either (error (errPath <> "Couldn't build PlutusV2 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV2 $ coerce @_ @[Int64] (Maestro.costModelsPlutusV2 protocolParametersPlutusCostModels) - ) - , plutusV3CostModels errPath - ] - , cppPrices = THKD $ Ledger.Prices {Ledger.prSteps = fromMaybe (error (errPath <> "Couldn't bound Maestro's cpu steps")) $ Ledger.boundRational $ Maestro.unMaestroRational $ Maestro.memoryCpuWithCpu protocolParametersScriptExecutionPrices, Ledger.prMem = fromMaybe (error (errPath <> "Couldn't bound Maestro's memory units")) $ Ledger.boundRational $ Maestro.unMaestroRational $ Maestro.memoryCpuWithMemory protocolParametersScriptExecutionPrices} - , cppMaxTxExUnits = THKD $ Ledger.OrdExUnits $ Ledger.ExUnits { - Ledger.exUnitsSteps = - Maestro.memoryCpuWithCpu protocolParametersMaxExecutionUnitsPerTransaction, - Ledger.exUnitsMem = - Maestro.memoryCpuWithMemory protocolParametersMaxExecutionUnitsPerTransaction - } - , cppMaxBlockExUnits = THKD $ Ledger.OrdExUnits $ Ledger.ExUnits { - Ledger.exUnitsSteps = - Maestro.memoryCpuWithCpu protocolParametersMaxExecutionUnitsPerBlock, - Ledger.exUnitsMem = - Maestro.memoryCpuWithMemory protocolParametersMaxExecutionUnitsPerBlock - } - , cppMaxValSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxValueSize - , cppCollateralPercentage = THKD $ fromIntegral protocolParametersCollateralPercentage - , cppMaxCollateralInputs = THKD $ fromIntegral protocolParametersMaxCollateralInputs - -- FIXME: Fetch these from provider. - , cppPoolVotingThresholds = THKD def - , cppDRepVotingThresholds = THKD def - , cppCommitteeMinSize = THKD 0 - , cppCommitteeMaxTermLength = THKD (Ledger.EpochInterval 0) - , cppGovActionLifetime = THKD (Ledger.EpochInterval 0) - , cppGovActionDeposit = THKD $ Ledger.Coin 0 - , cppDRepDeposit = THKD $ Ledger.Coin 0 - , cppDRepActivity = THKD (Ledger.EpochInterval 0) - , cppMinFeeRefScriptCostPerByte = THKD minBound - } + pure $ + Ledger.PParams $ + populateMissingProtocolParameters nid $ + ConwayPParams + { cppMinFeeA = THKD $ Ledger.Coin $ toInteger protocolParametersMinFeeCoefficient + , cppMinFeeB = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersMinFeeConstant + , cppMaxBBSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxBlockBodySize + , cppMaxTxSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxTransactionSize + , cppMaxBHSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxBlockHeaderSize + , cppKeyDeposit = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersStakeCredentialDeposit + , cppPoolDeposit = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersStakePoolDeposit + , cppEMax = + THKD $ + Ledger.EpochInterval . fromIntegral $ + Maestro.unEpochNo protocolParametersStakePoolRetirementEpochBound + , cppNOpt = THKD $ fromIntegral protocolParametersDesiredNumberOfStakePools + , cppA0 = THKD $ fromMaybe (error (errPath <> "Pool influence received from Maestro is out of bounds")) $ Ledger.boundRational $ Maestro.unMaestroRational protocolParametersStakePoolPledgeInfluence + , cppRho = THKD $ fromMaybe (error (errPath <> "Monetory expansion parameter received from Maestro is out of bounds")) $ Ledger.boundRational $ Maestro.unMaestroRational protocolParametersMonetaryExpansion + , cppTau = THKD $ fromMaybe (error (errPath <> "Treasury expansion parameter received from Maestro is out of bounds")) $ Ledger.boundRational $ Maestro.unMaestroRational protocolParametersTreasuryExpansion + , cppProtocolVersion = + Ledger.ProtVer + { Ledger.pvMajor = Ledger.mkVersion (Maestro.protocolVersionMajor protocolParametersVersion) & fromMaybe (error (errPath <> "Major version received from Maestro is out of bounds")) + , Ledger.pvMinor = Maestro.protocolVersionMinor protocolParametersVersion + } + , cppMinPoolCost = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersMinStakePoolCost + , cppCoinsPerUTxOByte = THKD $ Api.L.CoinPerByte $ Ledger.Coin $ toInteger protocolParametersMinUtxoDepositCoefficient + , cppCostModels = + THKD $ + Ledger.mkCostModels $ + M.fromList + [ + ( Ledger.PlutusV1 + , either (error (errPath <> "Couldn't build PlutusV1 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV1 $ coerce @_ @[Int64] (Maestro.costModelsPlutusV1 protocolParametersPlutusCostModels) + ) + , + ( Ledger.PlutusV2 + , either (error (errPath <> "Couldn't build PlutusV2 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV2 $ coerce @_ @[Int64] (Maestro.costModelsPlutusV2 protocolParametersPlutusCostModels) + ) + , plutusV3CostModels errPath + ] + , cppPrices = THKD $ Ledger.Prices {Ledger.prSteps = fromMaybe (error (errPath <> "Couldn't bound Maestro's cpu steps")) $ Ledger.boundRational $ Maestro.unMaestroRational $ Maestro.memoryCpuWithCpu protocolParametersScriptExecutionPrices, Ledger.prMem = fromMaybe (error (errPath <> "Couldn't bound Maestro's memory units")) $ Ledger.boundRational $ Maestro.unMaestroRational $ Maestro.memoryCpuWithMemory protocolParametersScriptExecutionPrices} + , cppMaxTxExUnits = + THKD $ + Ledger.OrdExUnits $ + Ledger.ExUnits + { Ledger.exUnitsSteps = + Maestro.memoryCpuWithCpu protocolParametersMaxExecutionUnitsPerTransaction + , Ledger.exUnitsMem = + Maestro.memoryCpuWithMemory protocolParametersMaxExecutionUnitsPerTransaction + } + , cppMaxBlockExUnits = + THKD $ + Ledger.OrdExUnits $ + Ledger.ExUnits + { Ledger.exUnitsSteps = + Maestro.memoryCpuWithCpu protocolParametersMaxExecutionUnitsPerBlock + , Ledger.exUnitsMem = + Maestro.memoryCpuWithMemory protocolParametersMaxExecutionUnitsPerBlock + } + , cppMaxValSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxValueSize + , cppCollateralPercentage = THKD $ fromIntegral protocolParametersCollateralPercentage + , cppMaxCollateralInputs = THKD $ fromIntegral protocolParametersMaxCollateralInputs + , -- FIXME: Fetch these from provider. + cppPoolVotingThresholds = THKD def + , cppDRepVotingThresholds = THKD def + , cppCommitteeMinSize = THKD 0 + , cppCommitteeMaxTermLength = THKD (Ledger.EpochInterval 0) + , cppGovActionLifetime = THKD (Ledger.EpochInterval 0) + , cppGovActionDeposit = THKD $ Ledger.Coin 0 + , cppDRepDeposit = THKD $ Ledger.Coin 0 + , cppDRepActivity = THKD (Ledger.EpochInterval 0) + , cppMinFeeRefScriptCostPerByte = THKD minBound + } where errPath = "GeniusYield.Providers.Maestro.maestroProtocolParams: " @@ -515,20 +544,23 @@ maestroStakePools env = do stkPoolsWithTicker <- handleMaestroError locationIdent <=< try $ Maestro.allPages (Maestro.listPools env) let stkPools = map (\(Maestro.PoolListInfo poolId _ticker) -> coerce poolId :: Text) stkPoolsWithTicker -- The pool ids returned by Maestro are in bech32. - let poolIdsEith = traverse + let poolIdsEith = + traverse (Api.deserialiseFromBech32 (Api.proxyToAsType $ Proxy @Api.S.PoolId)) stkPools case poolIdsEith of - -- Deserialization failure shouldn't happen on Maestro returned pool id. - Left err -> throwIO . MspvDeserializeFailure locationIdent $ DeserializeErrorBech32 err - Right has -> pure $ Set.fromList has + -- Deserialization failure shouldn't happen on Maestro returned pool id. + Left err -> throwIO . MspvDeserializeFailure locationIdent $ DeserializeErrorBech32 err + Right has -> pure $ Set.fromList has where locationIdent = "ListPools" -- | Returns the 'CTime.SystemStart' queried from Maestro. maestroSystemStart :: Maestro.MaestroEnv 'Maestro.V1 -> IO CTime.SystemStart -maestroSystemStart env = fmap (CTime.SystemStart . Time.localTimeToUTC Time.utc) . handleMaestroError "SystemStart" - <=< try $ Maestro.getTimestampedData <$> Maestro.getSystemStart env +maestroSystemStart env = + fmap (CTime.SystemStart . Time.localTimeToUTC Time.utc) . handleMaestroError "SystemStart" + <=< try + $ Maestro.getTimestampedData <$> Maestro.getSystemStart env -- | Returns the 'Api.EraHistory' queried from Maestro. maestroEraHistory :: Maestro.MaestroEnv 'Maestro.V1 -> IO Api.EraHistory @@ -536,18 +568,21 @@ maestroEraHistory env = do eraSumms <- handleMaestroError "EraHistory" =<< try (Maestro.getTimestampedData <$> Maestro.getEraHistory env) maybe (throwIO $ MspvIncorrectEraHistoryLength eraSumms) pure $ parseEraHist mkEra eraSumms where - mkBound Maestro.EraBound {eraBoundEpoch, eraBoundSlot, eraBoundTime} = Ouroboros.Bound + mkBound Maestro.EraBound {eraBoundEpoch, eraBoundSlot, eraBoundTime} = + Ouroboros.Bound { boundTime = CTime.RelativeTime $ Maestro.eraBoundTimeSeconds eraBoundTime , boundSlot = CSlot.SlotNo $ fromIntegral eraBoundSlot , boundEpoch = CSlot.EpochNo $ fromIntegral eraBoundEpoch } - mkEraParams Maestro.EraParameters {eraParametersEpochLength, eraParametersSlotLength, eraParametersSafeZone} = Ouroboros.EraParams + mkEraParams Maestro.EraParameters {eraParametersEpochLength, eraParametersSlotLength, eraParametersSafeZone} = + Ouroboros.EraParams { eraEpochSize = CSlot.EpochSize $ fromIntegral eraParametersEpochLength , eraSlotLength = CTime.mkSlotLength $ Maestro.epochSlotLengthMilliseconds eraParametersSlotLength / 1000 , eraSafeZone = Ouroboros.StandardSafeZone $ fromJust eraParametersSafeZone - , eraGenesisWin = fromIntegral $ fromJust eraParametersSafeZone -- TODO: Get it from provider? It is supposed to be 3k/f where k is security parameter (at present 2160) and f is active slot coefficient. Usually ledger set the safe zone size such that it guarantees at least k blocks... + , eraGenesisWin = fromIntegral $ fromJust eraParametersSafeZone -- TODO: Get it from provider? It is supposed to be 3k/f where k is security parameter (at present 2160) and f is active slot coefficient. Usually ledger set the safe zone size such that it guarantees at least k blocks... } - mkEra Maestro.EraSummary {eraSummaryStart, eraSummaryEnd, eraSummaryParameters} = Ouroboros.EraSummary + mkEra Maestro.EraSummary {eraSummaryStart, eraSummaryEnd, eraSummaryParameters} = + Ouroboros.EraSummary { eraStart = mkBound eraSummaryStart , eraEnd = maybe Ouroboros.EraUnbounded (Ouroboros.EraEnd . mkBound) eraSummaryEnd , eraParams = mkEraParams eraSummaryParameters @@ -561,9 +596,12 @@ maestroEraHistory env = do maestroLookupDatum :: Maestro.MaestroEnv 'Maestro.V1 -> GYLookupDatum maestroLookupDatum env dh = do datumMaybe <- handler =<< try (Maestro.getTimestampedData <$> (Maestro.getDatumByHash env . coerce . Api.serialiseToRawBytesHexText $ datumHashToApi dh)) - mapM (\(Maestro.Datum datumBytes _datumJson) -> case datumFromCBOR datumBytes of -- NOTE: `datumFromMaestroJSON datumJson` also gives the same result. - Left err -> throwIO $ MspvDeserializeFailure locationIdent err - Right bd -> pure bd) datumMaybe + mapM + ( \(Maestro.Datum datumBytes _datumJson) -> case datumFromCBOR datumBytes of -- NOTE: `datumFromMaestroJSON datumJson` also gives the same result. + Left err -> throwIO $ MspvDeserializeFailure locationIdent err + Right bd -> pure bd + ) + datumMaybe where locationIdent = "LookupDatum" -- This particular error is fine in this case, we can just return 'Nothing'. @@ -581,10 +619,14 @@ maestroStakeAddressInfo env saddr = do where -- This particular error is fine. handler (Left Maestro.MaestroNotFound) = pure Nothing - handler other = handleMaestroError "AccountInfo" $ other <&> \accInfo -> - if Maestro.accountInfoRegistered accInfo then Just $ - GYStakeAddressInfo - { gyStakeAddressInfoDelegatedPool = Maestro.accountInfoDelegatedPool accInfo >>= stakePoolIdFromTextMaybe . coerce - , gyStakeAddressInfoAvailableRewards = fromIntegral $ Maestro.accountInfoRewardsAvailable accInfo - } - else Nothing + handler other = + handleMaestroError "AccountInfo" $ + other <&> \accInfo -> + if Maestro.accountInfoRegistered accInfo + then + Just $ + GYStakeAddressInfo + { gyStakeAddressInfoDelegatedPool = Maestro.accountInfoDelegatedPool accInfo >>= stakePoolIdFromTextMaybe . coerce + , gyStakeAddressInfoAvailableRewards = fromIntegral $ Maestro.accountInfoRewardsAvailable accInfo + } + else Nothing diff --git a/src/GeniusYield/Providers/Node.hs b/src/GeniusYield/Providers/Node.hs index 32ef9272..01e61bc0 100644 --- a/src/GeniusYield/Providers/Node.hs +++ b/src/GeniusYield/Providers/Node.hs @@ -1,36 +1,37 @@ -{-| +{- | Module : GeniusYield.Providers.Node Description : Providers using local @cardano-node@ connection. Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Providers.Node - ( nodeSubmitTx - , nodeSlotActions - , nodeGetParameters - -- * Low-level - , nodeGetSlotOfCurrentBlock - , nodeStakeAddressInfo - -- * Auxiliary - , networkIdToLocalNodeConnectInfo - ) where - -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import qualified Cardano.Ledger.Coin as Ledger -import Cardano.Slotting.Time (SystemStart) -import Control.Exception (throwIO) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Text as Txt -import GeniusYield.CardanoApi.Query -import GeniusYield.Providers.Common (SubmitTxException (SubmitTxException)) -import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) -import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..)) +module GeniusYield.Providers.Node ( + nodeSubmitTx, + nodeSlotActions, + nodeGetParameters, + + -- * Low-level + nodeGetSlotOfCurrentBlock, + nodeStakeAddressInfo, + + -- * Auxiliary + networkIdToLocalNodeConnectInfo, +) where + +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Ledger.Coin qualified as Ledger +import Cardano.Slotting.Time (SystemStart) +import Control.Exception (throwIO) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as Txt +import GeniusYield.CardanoApi.Query +import GeniusYield.Providers.Common (SubmitTxException (SubmitTxException)) +import GeniusYield.Types +import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) +import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..)) ------------------------------------------------------------------------------- -- Submit @@ -38,11 +39,11 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult nodeSubmitTx :: Api.LocalNodeConnectInfo -> GYSubmitTx nodeSubmitTx info tx = do - -- We may submit transaction in older eras as well, it seems. - res <- Api.submitTxToNodeLocal info $ Api.TxInMode Api.ShelleyBasedEraConway (txToApi tx) - case res of - SubmitSuccess -> return $ txIdFromApi $ Api.getTxId $ Api.getTxBody $ txToApi tx - SubmitFail err -> throwIO $ SubmitTxException $ Txt.pack $ show err + -- We may submit transaction in older eras as well, it seems. + res <- Api.submitTxToNodeLocal info $ Api.TxInMode Api.ShelleyBasedEraConway (txToApi tx) + case res of + SubmitSuccess -> return $ txIdFromApi $ Api.getTxId $ Api.getTxBody $ txToApi tx + SubmitFail err -> throwIO $ SubmitTxException $ Txt.pack $ show err ------------------------------------------------------------------------------- -- Current slot @@ -50,14 +51,15 @@ nodeSubmitTx info tx = do nodeGetSlotOfCurrentBlock :: Api.LocalNodeConnectInfo -> IO GYSlot nodeGetSlotOfCurrentBlock info = do - Api.ChainTip s _ _ <- Api.getLocalChainTip info - return $ slotFromApi s + Api.ChainTip s _ _ <- Api.getLocalChainTip info + return $ slotFromApi s nodeSlotActions :: Api.LocalNodeConnectInfo -> GYSlotActions -nodeSlotActions info = GYSlotActions +nodeSlotActions info = + GYSlotActions { gyGetSlotOfCurrentBlock' = getSlotOfCurrentBlock - , gyWaitForNextBlock' = gyWaitForNextBlockDefault getSlotOfCurrentBlock - , gyWaitUntilSlot' = gyWaitUntilSlotDefault getSlotOfCurrentBlock + , gyWaitForNextBlock' = gyWaitForNextBlockDefault getSlotOfCurrentBlock + , gyWaitUntilSlot' = gyWaitUntilSlotDefault getSlotOfCurrentBlock } where getSlotOfCurrentBlock = nodeGetSlotOfCurrentBlock info @@ -73,18 +75,20 @@ nodeGetProtocolParameters :: Api.LocalNodeConnectInfo -> IO ApiProtocolParameter nodeGetProtocolParameters info = queryConwayEra info Api.QueryProtocolParameters stakePools :: Api.LocalNodeConnectInfo -> IO (Set.Set Api.S.PoolId) -stakePools info = queryConwayEra info Api.QueryStakePools +stakePools info = queryConwayEra info Api.QueryStakePools nodeStakeAddressInfo :: Api.LocalNodeConnectInfo -> GYStakeAddress -> IO (Maybe GYStakeAddressInfo) nodeStakeAddressInfo info saddr = resolveStakeAddressInfoFromApi saddr <$> queryConwayEra info (Api.QueryStakeAddresses (Set.singleton $ stakeCredentialToApi $ stakeAddressToCredential saddr) (Api.localNodeNetworkId info)) resolveStakeAddressInfoFromApi :: GYStakeAddress -> (Map.Map Api.StakeAddress Ledger.Coin, Map.Map Api.StakeAddress Api.S.PoolId) -> Maybe GYStakeAddressInfo resolveStakeAddressInfoFromApi (stakeAddressToApi -> stakeAddr) (rewards, delegations) = - if Map.member stakeAddr rewards - then Just $ GYStakeAddressInfo - { gyStakeAddressInfoAvailableRewards = fromIntegral $ Map.findWithDefault 0 stakeAddr rewards - , gyStakeAddressInfoDelegatedPool = stakePoolIdFromApi <$> Map.lookup stakeAddr delegations - } + if Map.member stakeAddr rewards + then + Just $ + GYStakeAddressInfo + { gyStakeAddressInfoAvailableRewards = fromIntegral $ Map.findWithDefault 0 stakeAddr rewards + , gyStakeAddressInfoDelegatedPool = stakePoolIdFromApi <$> Map.lookup stakeAddr delegations + } else Nothing systemStart :: Api.LocalNodeConnectInfo -> IO SystemStart @@ -98,12 +102,15 @@ eraHistory info = queryCardanoMode info Api.QueryEraHistory ------------------------------------------------------------------------------- -- | Constructs the connection info to a local node. --- -networkIdToLocalNodeConnectInfo :: GYNetworkId -- ^ The network identifier. - -> FilePath -- ^ Path to the local node socket. - -> Api.LocalNodeConnectInfo -networkIdToLocalNodeConnectInfo nid nodeSocket = Api.LocalNodeConnectInfo +networkIdToLocalNodeConnectInfo :: + -- | The network identifier. + GYNetworkId -> + -- | Path to the local node socket. + FilePath -> + Api.LocalNodeConnectInfo +networkIdToLocalNodeConnectInfo nid nodeSocket = + Api.LocalNodeConnectInfo { localConsensusModeParams = Api.CardanoModeParams $ networkIdToEpochSlots nid - , localNodeNetworkId = networkIdToApi nid - , localNodeSocketPath = Api.File nodeSocket + , localNodeNetworkId = networkIdToApi nid + , localNodeSocketPath = Api.File nodeSocket } diff --git a/src/GeniusYield/Providers/Node/AwaitTx.hs b/src/GeniusYield/Providers/Node/AwaitTx.hs index ee5f550b..5862abac 100644 --- a/src/GeniusYield/Providers/Node/AwaitTx.hs +++ b/src/GeniusYield/Providers/Node/AwaitTx.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.Providers.Node.AwaitTx Description : AwaitTx provider using local node. Inefficient, for testing purposes only. Copyright : (c) 2023 GYELD GMBH @@ -8,19 +8,18 @@ Stability : develop **INTERNAL MODULE** -} - module GeniusYield.Providers.Node.AwaitTx ( - nodeAwaitTxConfirmed + nodeAwaitTxConfirmed, ) where -import Control.Concurrent (threadDelay) -import Control.Exception (throwIO) -import Control.Monad (unless) +import Control.Concurrent (threadDelay) +import Control.Exception (throwIO) +import Control.Monad (unless) -import qualified Cardano.Api as Api +import Cardano.Api qualified as Api -import GeniusYield.Providers.Node.Query -import GeniusYield.Types +import GeniusYield.Providers.Node.Query +import GeniusYield.Types {- TODO: Perhaps it's possible to do this more efficiently using one of the node mini protocols. @@ -38,7 +37,7 @@ created since the tx - thus, there have been at least k confirmations. See: https://docs.cardano.org/about-cardano/learn/chain-confirmation-versus-transaction-confirmation/ -} nodeAwaitTxConfirmed :: Api.LocalNodeConnectInfo -> GYAwaitTx -nodeAwaitTxConfirmed info p@GYAwaitTxParameters{..} txId = go 0 +nodeAwaitTxConfirmed info p@GYAwaitTxParameters {..} txId = go 0 where go attempt | attempt >= maxAttempts = throwIO $ GYAwaitTxException p @@ -53,30 +52,30 @@ nodeAwaitTxConfirmed info p@GYAwaitTxParameters{..} txId = go 0 utxos <- nodeUtxosFromTx info txId -- FIXME: This doesn't actually wait for confirmations. unless (utxosSize utxos /= 0) $ - threadDelay checkInterval >> go (attempt + 1) + threadDelay checkInterval >> go (attempt + 1) -- | Obtain UTxOs created by a transaction. -nodeUtxosFromTx :: Api.LocalNodeConnectInfo -> GYTxId -> IO GYUTxOs +nodeUtxosFromTx :: Api.LocalNodeConnectInfo -> GYTxId -> IO GYUTxOs nodeUtxosFromTx info txId = do - {- We don't have a way to obtain utxos produced by a TxId. As an alternative, we could - obtain the whole UTxO set and filter from there, but there's a faster way. + {- We don't have a way to obtain utxos produced by a TxId. As an alternative, we could + obtain the whole UTxO set and filter from there, but there's a faster way. - We can query utxos from `TxOutRef`s. And the `TxOutRef`s of all the utxos produced by a transaction - will be a product of the TxId (which we know) and the index of each output of the transaction. + We can query utxos from `TxOutRef`s. And the `TxOutRef`s of all the utxos produced by a transaction + will be a product of the TxId (which we know) and the index of each output of the transaction. - We start by guessing that each transaction produces 10 outputs, and query with all `TxOutRef`s such that - their TxId part is the transaction id and the index part is `0..10`. Then, we try with `11..20` and so on - until we get no utxos in return. Then we are done. + We start by guessing that each transaction produces 10 outputs, and query with all `TxOutRef`s such that + their TxId part is the transaction id and the index part is `0..10`. Then, we try with `11..20` and so on + until we get no utxos in return. Then we are done. - Hacky, but works fine for testing. - -} - let startIx = 0 - uptoIx = 10 - go mempty startIx uptoIx + Hacky, but works fine for testing. + -} + let startIx = 0 + uptoIx = 10 + go mempty startIx uptoIx where go acc startIx uptoIx = do - utxos <- nodeUtxosAtTxOutRefs info $ curry txOutRefFromTuple txId <$> [startIx .. uptoIx] - let acc' = acc <> utxos - if utxosSize utxos == 0 - then pure acc' - else go acc' (uptoIx + 1) (uptoIx * 2) + utxos <- nodeUtxosAtTxOutRefs info $ curry txOutRefFromTuple txId <$> [startIx .. uptoIx] + let acc' = acc <> utxos + if utxosSize utxos == 0 + then pure acc' + else go acc' (uptoIx + 1) (uptoIx * 2) diff --git a/src/GeniusYield/Providers/Node/Query.hs b/src/GeniusYield/Providers/Node/Query.hs index c66c37d5..309729b3 100644 --- a/src/GeniusYield/Providers/Node/Query.hs +++ b/src/GeniusYield/Providers/Node/Query.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.Providers.Node.Query Description : QueryUTxO provider using local node. Inefficient, for testing purposes only. Copyright : (c) 2023 GYELD GMBH @@ -8,24 +8,23 @@ Stability : develop **INTERNAL MODULE** -} - module GeniusYield.Providers.Node.Query ( - nodeQueryUTxO, - nodeUtxosAtAddress, - nodeUtxosAtAddresses, - nodeUtxoAtTxOutRef, - nodeUtxosAtTxOutRefs, - nodeUtxosAtPaymentCredential, - nodeUtxosAtPaymentCredentials + nodeQueryUTxO, + nodeUtxosAtAddress, + nodeUtxosAtAddresses, + nodeUtxoAtTxOutRef, + nodeUtxosAtTxOutRefs, + nodeUtxosAtPaymentCredential, + nodeUtxosAtPaymentCredentials, ) where -import qualified Data.Set as Set +import Data.Set qualified as Set -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S -import GeniusYield.CardanoApi.Query -import GeniusYield.Types +import GeniusYield.CardanoApi.Query +import GeniusYield.Types ------------------------------------------------------------------------------- -- UTxO query @@ -33,21 +32,21 @@ import GeniusYield.Types nodeUtxosAtAddress :: Api.LocalNodeConnectInfo -> GYAddress -> Maybe GYAssetClass -> IO GYUTxOs nodeUtxosAtAddress info addr mAssetClass = do - utxos <- nodeUtxosAtAddresses info [addr] - pure $ case mAssetClass of - Nothing -> utxos - Just assetClass -> filterUTxOs (\GYUTxO {utxoValue} -> valueAssetClass utxoValue assetClass /= 0) utxos + utxos <- nodeUtxosAtAddresses info [addr] + pure $ case mAssetClass of + Nothing -> utxos + Just assetClass -> filterUTxOs (\GYUTxO {utxoValue} -> valueAssetClass utxoValue assetClass /= 0) utxos nodeUtxosAtAddresses :: Api.LocalNodeConnectInfo -> [GYAddress] -> IO GYUTxOs nodeUtxosAtAddresses info addrs = do - queryUTxO info $ Api.QueryUTxOByAddress $ Set.fromList $ addressToApi <$> addrs + queryUTxO info $ Api.QueryUTxOByAddress $ Set.fromList $ addressToApi <$> addrs nodeUtxoAtTxOutRef :: Api.LocalNodeConnectInfo -> GYTxOutRef -> IO (Maybe GYUTxO) nodeUtxoAtTxOutRef info ref = do - utxos <- nodeUtxosAtTxOutRefs info [ref] - case utxosToList utxos of - [x] | utxoRef x == ref -> return (Just x) - _ -> return Nothing -- we return Nothing also in "should never happen" cases. + utxos <- nodeUtxosAtTxOutRefs info [ref] + case utxosToList utxos of + [x] | utxoRef x == ref -> return (Just x) + _ -> return Nothing -- we return Nothing also in "should never happen" cases. nodeUtxosAtTxOutRefs :: Api.LocalNodeConnectInfo -> [GYTxOutRef] -> IO GYUTxOs nodeUtxosAtTxOutRefs info refs = queryUTxO info $ Api.QueryUTxOByTxIn $ Set.fromList $ txOutRefToApi <$> refs @@ -55,33 +54,34 @@ nodeUtxosAtTxOutRefs info refs = queryUTxO info $ Api.QueryUTxOByTxIn $ Set.from -- NOTE: This is extremely inefficient and only viable for a small private testnet. It queries the whole UTxO set. nodeUtxosAtPaymentCredential :: Api.LocalNodeConnectInfo -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs nodeUtxosAtPaymentCredential info cred mAssetClass = do - utxos <- nodeUtxosAtPaymentCredentials info [cred] - pure $ case mAssetClass of - Nothing -> utxos - Just assetClass -> filterUTxOs (\GYUTxO {utxoValue} -> valueAssetClass utxoValue assetClass /= 0) utxos + utxos <- nodeUtxosAtPaymentCredentials info [cred] + pure $ case mAssetClass of + Nothing -> utxos + Just assetClass -> filterUTxOs (\GYUTxO {utxoValue} -> valueAssetClass utxoValue assetClass /= 0) utxos -- NOTE: This is extremely inefficient and only viable for a small private testnet. It queries the whole UTxO set. nodeUtxosAtPaymentCredentials :: Api.LocalNodeConnectInfo -> [GYPaymentCredential] -> IO GYUTxOs nodeUtxosAtPaymentCredentials info creds = do - allUtxos <- queryUTxO info Api.QueryUTxOWhole - pure $ filterUTxOs (\GYUTxO {utxoAddress} -> matchesCred $ addressToPaymentCredential utxoAddress) allUtxos + allUtxos <- queryUTxO info Api.QueryUTxOWhole + pure $ filterUTxOs (\GYUTxO {utxoAddress} -> matchesCred $ addressToPaymentCredential utxoAddress) allUtxos where credSet = Set.fromList creds - matchesCred Nothing = False + matchesCred Nothing = False matchesCred (Just cred) = cred `Set.member` credSet nodeQueryUTxO :: Api.S.LocalNodeConnectInfo -> GYQueryUTxO -nodeQueryUTxO info = GYQueryUTxO - { gyQueryUtxosAtTxOutRefsWithDatums' = Nothing - , gyQueryUtxosAtTxOutRefs' = nodeUtxosAtTxOutRefs info +nodeQueryUTxO info = + GYQueryUTxO + { gyQueryUtxosAtTxOutRefsWithDatums' = Nothing + , gyQueryUtxosAtTxOutRefs' = nodeUtxosAtTxOutRefs info , gyQueryUtxosAtPaymentCredsWithDatums' = Nothing - , gyQueryUtxosAtPaymentCredentials' = nodeUtxosAtPaymentCredentials info - , gyQueryUtxosAtPaymentCredential' = nodeUtxosAtPaymentCredential info - , gyQueryUtxosAtPaymentCredWithDatums' = Nothing - , gyQueryUtxosAtAddressesWithDatums' = Nothing - , gyQueryUtxosAtAddresses' = nodeUtxosAtAddresses info - , gyQueryUtxosAtAddressWithDatums' = Nothing - , gyQueryUtxosAtAddress' = nodeUtxosAtAddress info - , gyQueryUtxoRefsAtAddress' = gyQueryUtxoRefsAtAddressDefault $ nodeUtxosAtAddress info - , gyQueryUtxoAtTxOutRef' = nodeUtxoAtTxOutRef info + , gyQueryUtxosAtPaymentCredentials' = nodeUtxosAtPaymentCredentials info + , gyQueryUtxosAtPaymentCredential' = nodeUtxosAtPaymentCredential info + , gyQueryUtxosAtPaymentCredWithDatums' = Nothing + , gyQueryUtxosAtAddressesWithDatums' = Nothing + , gyQueryUtxosAtAddresses' = nodeUtxosAtAddresses info + , gyQueryUtxosAtAddressWithDatums' = Nothing + , gyQueryUtxosAtAddress' = nodeUtxosAtAddress info + , gyQueryUtxoRefsAtAddress' = gyQueryUtxoRefsAtAddressDefault $ nodeUtxosAtAddress info + , gyQueryUtxoAtTxOutRef' = nodeUtxoAtTxOutRef info } diff --git a/src/GeniusYield/Providers/Sentry.hs b/src/GeniusYield/Providers/Sentry.hs index b2e22ca1..155b97b7 100644 --- a/src/GeniusYield/Providers/Sentry.hs +++ b/src/GeniusYield/Providers/Sentry.hs @@ -1,36 +1,36 @@ -{-| +{- | Module : GeniusYield.Providers.Sentry Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Providers.Sentry where -import qualified Data.Aeson as Aeson -import Data.Aeson.KeyMap (fromHashMapText, - toHashMapText) -import Data.Bifunctor (first) -import Data.HashMap.Internal (HashMap) -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as Builder -import qualified Katip -import qualified Katip.Core -import qualified System.Log.Raven as Raven -import System.Log.Raven.Transport.HttpConduit (sendRecord) -import qualified System.Log.Raven.Types as Raven - +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap ( + fromHashMapText, + toHashMapText, + ) +import Data.Bifunctor (first) +import Data.HashMap.Internal (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Builder qualified as Builder +import Katip qualified +import Katip.Core qualified +import System.Log.Raven qualified as Raven +import System.Log.Raven.Transport.HttpConduit (sendRecord) +import System.Log.Raven.Types qualified as Raven mkSentryScribe :: Raven.SentryService -> Katip.PermitFunc -> Katip.Verbosity -> IO Katip.Scribe mkSentryScribe ss pf vb = return $ Katip.Scribe logger (return ()) pf where - logger :: Katip.LogItem a => Katip.Item a -> IO () + logger :: (Katip.LogItem a) => Katip.Item a -> IO () logger item = do let lvl = sentryLevel $ Katip._itemSeverity item - msg = TL.unpack $ Builder.toLazyText $ Katip.unLogStr $ Katip._itemMessage item + msg = TL.unpack $ Builder.toLazyText $ Katip.unLogStr $ Katip._itemMessage item nmSpace = sentryNamespace $ Katip._itemNamespace item -- Register Sentry event @@ -38,30 +38,31 @@ mkSentryScribe ss pf vb = return $ Katip.Scribe logger (return ()) pf Raven.register ss nmSpace lvl msg (`updateRecord` item) -- send Ktip.Loc data to sentry - locAttr :: Katip.LogItem a => Katip.Item a -> HashMap T.Text Aeson.Value + locAttr :: (Katip.LogItem a) => Katip.Item a -> HashMap T.Text Aeson.Value locAttr item = foldMap (HM.singleton "loc" . Aeson.toJSON . Katip.Core.LocJs) (Katip._itemLoc item) -- extra attributes we can send to sentry - srExtra :: Katip.LogItem a => Katip.Item a -> HashMap String Aeson.Value + srExtra :: (Katip.LogItem a) => Katip.Item a -> HashMap String Aeson.Value srExtra item = toStringHashMap $ toHashMapText $ Katip.payloadObject vb (Katip._itemPayload item) <> fromHashMapText (locAttr item) - where - toStringHashMap :: HashMap T.Text Aeson.Value -> HashMap String Aeson.Value - toStringHashMap = HM.fromList . map (first T.unpack) . HM.toList + where + toStringHashMap :: HashMap T.Text Aeson.Value -> HashMap String Aeson.Value + toStringHashMap = HM.fromList . map (first T.unpack) . HM.toList - updateRecord :: Katip.LogItem a => Raven.SentryRecord -> Katip.Item a -> Raven.SentryRecord - updateRecord record item = record - { Raven.srEnvironment = Just $ T.unpack $ Katip.getEnvironment $ Katip._itemEnv item - , Raven.srExtra = srExtra item - , Raven.srTimestamp = Katip._itemTime item - } + updateRecord :: (Katip.LogItem a) => Raven.SentryRecord -> Katip.Item a -> Raven.SentryRecord + updateRecord record item = + record + { Raven.srEnvironment = Just $ T.unpack $ Katip.getEnvironment $ Katip._itemEnv item + , Raven.srExtra = srExtra item + , Raven.srTimestamp = Katip._itemTime item + } -- Sentry Level for Katip Log sentryLevel :: Katip.Severity -> Raven.SentryLevel - sentryLevel Katip.DebugS = Raven.Debug - sentryLevel Katip.InfoS = Raven.Info - sentryLevel Katip.ErrorS = Raven.Error + sentryLevel Katip.DebugS = Raven.Debug + sentryLevel Katip.InfoS = Raven.Info + sentryLevel Katip.ErrorS = Raven.Error sentryLevel Katip.WarningS = Raven.Warning - sentryLevel _ = Raven.Custom "Other" + sentryLevel _ = Raven.Custom "Other" -- gives proper namespace for sentry -- @@ -71,8 +72,8 @@ mkSentryScribe ss pf vb = return $ Katip.Scribe logger (return ()) pf sentryNamespace :: Katip.Namespace -> String sentryNamespace (Katip.Namespace ks) = T.unpack $ T.intercalate "." ks - -- minimum sentry service constructed from dsn sentryService :: String -> Raven.SentryService -sentryService dsn = let sSettings = Raven.fromDSN dsn in - Raven.SentryService sSettings id sendRecord Raven.silentFallback +sentryService dsn = + let sSettings = Raven.fromDSN dsn + in Raven.SentryService sSettings id sendRecord Raven.silentFallback diff --git a/src/GeniusYield/ReadJSON.hs b/src/GeniusYield/ReadJSON.hs index c03a5717..52642a45 100644 --- a/src/GeniusYield/ReadJSON.hs +++ b/src/GeniusYield/ReadJSON.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.ReadJSON Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 @@ -6,16 +6,16 @@ Maintainer : support@geniusyield.co Stability : develop -} module GeniusYield.ReadJSON ( - readJSON + readJSON, ) where -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LBS -import GeniusYield.Imports +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as LBS +import GeniusYield.Imports -readJSON :: FromJSON a => FilePath -> IO a +readJSON :: (FromJSON a) => FilePath -> IO a readJSON fp = do bs <- LBS.readFile fp case Aeson.eitherDecode' bs of - Left err -> throwIO $ userError err + Left err -> throwIO $ userError err Right cfg -> pure cfg diff --git a/src/GeniusYield/Scripts/TestToken.hs b/src/GeniusYield/Scripts/TestToken.hs index 208a06ca..2d40cd23 100644 --- a/src/GeniusYield/Scripts/TestToken.hs +++ b/src/GeniusYield/Scripts/TestToken.hs @@ -1,23 +1,25 @@ -{-| +{- | Module : GeniusYield.Scripts.TestToken Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Scripts.TestToken ( - testTokenPolicy, + testTokenPolicy, ) where -import GeniusYield.OnChain.TestToken.Compiled (originalTestTokenPolicy) -import GeniusYield.Types +import GeniusYield.OnChain.TestToken.Compiled (originalTestTokenPolicy) +import GeniusYield.Types -testTokenPolicy - :: Integer -- ^ count - -> GYTokenName -- ^ token name (e.g. @GOLD@) - -> GYTxOutRef -- ^ utxo to base token on - -> GYMintingPolicy 'PlutusV2 +testTokenPolicy :: + -- | count + Integer -> + -- | token name (e.g. @GOLD@) + GYTokenName -> + -- | utxo to base token on + GYTxOutRef -> + GYMintingPolicy 'PlutusV2 testTokenPolicy count tn utxo = - mintingPolicyFromPlutus @'PlutusV2 - $ originalTestTokenPolicy count (tokenNameToPlutus tn) (txOutRefToPlutus utxo) + mintingPolicyFromPlutus @'PlutusV2 $ + originalTestTokenPolicy count (tokenNameToPlutus tn) (txOutRefToPlutus utxo) diff --git a/src/GeniusYield/Test/Clb.hs b/src/GeniusYield/Test/Clb.hs index d2a28b12..42a6e798 100644 --- a/src/GeniusYield/Test/Clb.hs +++ b/src/GeniusYield/Test/Clb.hs @@ -1,100 +1,111 @@ {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-| +{- | Module : GeniusYield.Test.Clb Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Test.Clb - ( GYTxMonadClb - , mkTestFor - , asClb - , asRandClb - , liftClb - , dumpUtxoState - , mustFail - , mustFailWith - , sendSkeleton - , sendSkeleton' - , logInfoS - ) where - -import Control.Lens ((^.)) -import Control.Monad.Except -import Control.Monad.Random -import Control.Monad.Reader -import Control.Monad.State -import qualified Data.Map.Strict as Map -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import Data.SOP.NonEmpty (NonEmpty (NonEmptyCons, NonEmptyOne)) -import qualified Data.Text as T -import Data.Time.Clock (NominalDiffTime, - UTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) - -import qualified Cardano.Api as Api -import qualified Cardano.Api.Script as Api -import qualified Cardano.Api.Shelley as Api.S -import qualified Cardano.Ledger.Address as L -import qualified Cardano.Ledger.Api as L -import qualified Cardano.Ledger.Compactible as L -import qualified Cardano.Ledger.Conway.Core as ConwayCore -import qualified Cardano.Ledger.Core as L -import qualified Cardano.Ledger.Plutus.TxInfo as L -import qualified Cardano.Ledger.Shelley.API as L.S -import qualified Cardano.Ledger.UTxO as L -import Cardano.Slotting.Slot (EpochNo (..), - EpochSize (..)) -import Cardano.Slotting.Time (RelativeTime (RelativeTime), - mkSlotLength) -import Clb (ClbState (..), - Clb, - ClbT, - EmulatedLedgerState (..), - Log (Log), - LogEntry (LogEntry), - LogLevel (..), - MockConfig (..), - SlotConfig (..), - ValidationResult (..), - getCurrentSlot, - getFails, - logError, - logInfo, - sendTx, - txOutRefAt, - txOutRefAtPaymentCred, - unLog, - waitSlot) -import qualified Clb -import Control.Monad.Trans.Maybe (runMaybeT) -import qualified Ouroboros.Consensus.Cardano.Block as Ouroboros -import qualified Ouroboros.Consensus.HardFork.History as Ouroboros -import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (eraGenesisWin)) -import qualified PlutusLedgerApi.V2 as Plutus -import Prettyprinter (PageWidth (AvailablePerLine), - defaultLayoutOptions, - layoutPageWidth, - layoutPretty) -import Prettyprinter.Render.String (renderString) -import qualified Test.Cardano.Ledger.Core.KeyPair as TL -import qualified Test.Tasty as Tasty -import Test.Tasty.HUnit (assertFailure, - testCaseInfo) - -import GeniusYield.HTTP.Errors -import GeniusYield.Imports -import GeniusYield.Test.Utils -import GeniusYield.TxBuilder.Class -import GeniusYield.TxBuilder.Common -import GeniusYield.TxBuilder.Errors -import GeniusYield.TxBuilder.User -import GeniusYield.Types +module GeniusYield.Test.Clb ( + GYTxMonadClb, + mkTestFor, + asClb, + asRandClb, + liftClb, + dumpUtxoState, + mustFail, + mustFailWith, + sendSkeleton, + sendSkeleton', + logInfoS, +) where + +import Control.Lens ((^.)) +import Control.Monad.Except +import Control.Monad.Random +import Control.Monad.Reader +import Control.Monad.State +import Data.Map.Strict qualified as Map +import Data.SOP.NonEmpty (NonEmpty (NonEmptyCons, NonEmptyOne)) +import Data.Sequence qualified as Seq +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Time.Clock ( + NominalDiffTime, + UTCTime, + ) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) + +import Cardano.Api qualified as Api +import Cardano.Api.Script qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Ledger.Address qualified as L +import Cardano.Ledger.Api qualified as L +import Cardano.Ledger.Compactible qualified as L +import Cardano.Ledger.Conway.Core qualified as ConwayCore +import Cardano.Ledger.Core qualified as L +import Cardano.Ledger.Plutus.TxInfo qualified as L +import Cardano.Ledger.Shelley.API qualified as L.S +import Cardano.Ledger.UTxO qualified as L +import Cardano.Slotting.Slot ( + EpochNo (..), + EpochSize (..), + ) +import Cardano.Slotting.Time ( + RelativeTime (RelativeTime), + mkSlotLength, + ) +import Clb ( + Clb, + ClbState (..), + ClbT, + EmulatedLedgerState (..), + Log (Log), + LogEntry (LogEntry), + LogLevel (..), + MockConfig (..), + SlotConfig (..), + ValidationResult (..), + getCurrentSlot, + getFails, + logError, + logInfo, + sendTx, + txOutRefAt, + txOutRefAtPaymentCred, + unLog, + waitSlot, + ) +import Clb qualified +import Control.Monad.Trans.Maybe (runMaybeT) +import Ouroboros.Consensus.Cardano.Block qualified as Ouroboros +import Ouroboros.Consensus.HardFork.History qualified as Ouroboros +import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (eraGenesisWin)) +import PlutusLedgerApi.V2 qualified as Plutus +import Prettyprinter ( + PageWidth (AvailablePerLine), + defaultLayoutOptions, + layoutPageWidth, + layoutPretty, + ) +import Prettyprinter.Render.String (renderString) +import Test.Cardano.Ledger.Core.KeyPair qualified as TL +import Test.Tasty qualified as Tasty +import Test.Tasty.HUnit ( + assertFailure, + testCaseInfo, + ) + +import GeniusYield.HTTP.Errors +import GeniusYield.Imports +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder.Class +import GeniusYield.TxBuilder.Common +import GeniusYield.TxBuilder.Errors +import GeniusYield.TxBuilder.User +import GeniusYield.Types deriving newtype instance Num EpochSize deriving newtype instance Num EpochNo @@ -102,43 +113,45 @@ deriving newtype instance Num EpochNo type AtlasClb = Clb ApiEra newtype GYTxClbEnv = GYTxClbEnv - { clbEnvWallet :: User - -- ^ The actor for a GYTxMonadClb action. - } + { clbEnvWallet :: User + -- ^ The actor for a GYTxMonadClb action. + } newtype GYTxClbState = GYTxClbState - { clbNextWalletInt :: Integer - -- ^ Next integer to use with 'Clb.intToKeyPair' call in order to generate a new user. - } + { clbNextWalletInt :: Integer + -- ^ Next integer to use with 'Clb.intToKeyPair' call in order to generate a new user. + } newtype GYTxMonadClb a = GYTxMonadClb - { unGYTxMonadClb :: ReaderT GYTxClbEnv (StateT GYTxClbState (ExceptT GYTxMonadException (RandT StdGen AtlasClb))) a - } - deriving newtype (Functor, Applicative, Monad, MonadReader GYTxClbEnv, MonadState GYTxClbState) - deriving anyclass GYTxBuilderMonad + { unGYTxMonadClb :: ReaderT GYTxClbEnv (StateT GYTxClbState (ExceptT GYTxMonadException (RandT StdGen AtlasClb))) a + } + deriving newtype (Functor, Applicative, Monad, MonadReader GYTxClbEnv, MonadState GYTxClbState) + deriving anyclass (GYTxBuilderMonad) instance MonadRandom GYTxMonadClb where - getRandomR = GYTxMonadClb . getRandomR - getRandom = GYTxMonadClb getRandom - getRandomRs = GYTxMonadClb . getRandomRs - getRandoms = GYTxMonadClb getRandoms - -asRandClb :: User - -> Integer - -> GYTxMonadClb a - -> RandT StdGen AtlasClb (Maybe a) + getRandomR = GYTxMonadClb . getRandomR + getRandom = GYTxMonadClb getRandom + getRandomRs = GYTxMonadClb . getRandomRs + getRandoms = GYTxMonadClb getRandoms + +asRandClb :: + User -> + Integer -> + GYTxMonadClb a -> + RandT StdGen AtlasClb (Maybe a) asRandClb w i m = do - e <- runExceptT $ (unGYTxMonadClb m `runReaderT` GYTxClbEnv w) `runStateT` GYTxClbState { clbNextWalletInt = i } - case e of - Left (GYApplicationException (toApiError -> GYApiError {gaeMsg})) -> lift (logError $ T.unpack gaeMsg) >> return Nothing - Left err -> lift (logError $ show err) >> return Nothing - Right (a, _) -> return $ Just a - -asClb :: StdGen - -> User - -> Integer - -> GYTxMonadClb a - -> AtlasClb (Maybe a) + e <- runExceptT $ (unGYTxMonadClb m `runReaderT` GYTxClbEnv w) `runStateT` GYTxClbState {clbNextWalletInt = i} + case e of + Left (GYApplicationException (toApiError -> GYApiError {gaeMsg})) -> lift (logError $ T.unpack gaeMsg) >> return Nothing + Left err -> lift (logError $ show err) >> return Nothing + Right (a, _) -> return $ Just a + +asClb :: + StdGen -> + User -> + Integer -> + GYTxMonadClb a -> + AtlasClb (Maybe a) asClb g w i m = evalRandT (asRandClb w i m) g liftClb :: AtlasClb a -> GYTxMonadClb a @@ -149,60 +162,63 @@ liftClb = GYTxMonadClb . lift . lift . lift . lift -} mkTestFor :: String -> (TestInfo -> GYTxMonadClb a) -> Tasty.TestTree mkTestFor name action = - testNoErrorsTraceClb v w Clb.defaultConway name $ do - asClb pureGen (w1 testWallets) nextWalletInt - $ action TestInfo { testGoldAsset = fakeCoin fakeGold, testIronAsset = fakeCoin fakeIron, testWallets } + testNoErrorsTraceClb v w Clb.defaultConway name $ do + asClb pureGen (w1 testWallets) nextWalletInt $ + action TestInfo {testGoldAsset = fakeCoin fakeGold, testIronAsset = fakeCoin fakeIron, testWallets} where -- TODO (simplify-genesis): Remove generation of non ada funds. - v = valueFromLovelace 1_000_000_000_000_000 <> - fakeValue fakeGold 1_000_000_000 <> - fakeValue fakeIron 1_000_000_000 + v = + valueFromLovelace 1_000_000_000_000_000 + <> fakeValue fakeGold 1_000_000_000 + <> fakeValue fakeIron 1_000_000_000 - w = valueFromLovelace 1_000_000_000_000 <> - fakeValue fakeGold 1_000_000 <> - fakeValue fakeIron 1_000_000 + w = + valueFromLovelace 1_000_000_000_000 + <> fakeValue fakeGold 1_000_000 + <> fakeValue fakeIron 1_000_000 -- TODO (simplify-genesis):: Remove creation of wallets. Only create one (or more) genesis/funder wallet and pass it on. testWallets :: Wallets - testWallets = Wallets - (mkSimpleWallet (Clb.intToKeyPair 1)) - (mkSimpleWallet (Clb.intToKeyPair 2)) - (mkSimpleWallet (Clb.intToKeyPair 3)) - (mkSimpleWallet (Clb.intToKeyPair 4)) - (mkSimpleWallet (Clb.intToKeyPair 5)) - (mkSimpleWallet (Clb.intToKeyPair 6)) - (mkSimpleWallet (Clb.intToKeyPair 7)) - (mkSimpleWallet (Clb.intToKeyPair 8)) - (mkSimpleWallet (Clb.intToKeyPair 9)) + testWallets = + Wallets + (mkSimpleWallet (Clb.intToKeyPair 1)) + (mkSimpleWallet (Clb.intToKeyPair 2)) + (mkSimpleWallet (Clb.intToKeyPair 3)) + (mkSimpleWallet (Clb.intToKeyPair 4)) + (mkSimpleWallet (Clb.intToKeyPair 5)) + (mkSimpleWallet (Clb.intToKeyPair 6)) + (mkSimpleWallet (Clb.intToKeyPair 7)) + (mkSimpleWallet (Clb.intToKeyPair 8)) + (mkSimpleWallet (Clb.intToKeyPair 9)) -- This is the next consecutive number after the highest one used above for 'Clb.intToKeyPair' calls. nextWalletInt :: Integer nextWalletInt = 10 - -- | Helper for building tests + -- \| Helper for building tests testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig ApiEra -> String -> AtlasClb a -> Tasty.TestTree testNoErrorsTraceClb funds walletFunds cfg msg act = - testCaseInfo msg - $ maybe (pure mockLog) assertFailure - $ mbErrors >>= \errors -> pure (mockLog <> "\n\nError :\n-------\n" <> errors) - where - -- _errors since we decided to store errors in the log as well. - (mbErrors, mock) = Clb.runClb (act >> Clb.checkErrors) $ Clb.initClb cfg (valueToApi funds) (valueToApi walletFunds) - mockLog = "\nEmulator log :\n--------------\n" <> logString - options = defaultLayoutOptions { layoutPageWidth = AvailablePerLine 150 1.0} - logDoc = Clb.ppLog $ Clb.mockInfo mock - logString = renderString $ layoutPretty options logDoc - + testCaseInfo msg $ + maybe (pure mockLog) assertFailure $ + mbErrors >>= \errors -> pure (mockLog <> "\n\nError :\n-------\n" <> errors) + where + -- _errors since we decided to store errors in the log as well. + (mbErrors, mock) = Clb.runClb (act >> Clb.checkErrors) $ Clb.initClb cfg (valueToApi funds) (valueToApi walletFunds) + mockLog = "\nEmulator log :\n--------------\n" <> logString + options = defaultLayoutOptions {layoutPageWidth = AvailablePerLine 150 1.0} + logDoc = Clb.ppLog $ Clb.mockInfo mock + logString = renderString $ layoutPretty options logDoc mkSimpleWallet :: TL.KeyPair r L.StandardCrypto -> User mkSimpleWallet kp = - let key = paymentSigningKeyFromLedgerKeyPair kp - in User' - { userPaymentSKey' = key - , userStakeSKey' = Nothing - , userAddr = addressFromPaymentKeyHash GYTestnetPreprod . paymentKeyHash $ - paymentVerificationKey key - } + let key = paymentSigningKeyFromLedgerKeyPair kp + in User' + { userPaymentSKey' = key + , userStakeSKey' = Nothing + , userAddr = + addressFromPaymentKeyHash GYTestnetPreprod . paymentKeyHash $ + paymentVerificationKey key + } {- | Try to execute an action, and if it fails, restore to the current state while preserving logs. If the action succeeds, logs an error as we expect @@ -215,319 +231,332 @@ mustFail = mustFailWith (const True) mustFailWith :: (GYTxMonadException -> Bool) -> GYTxMonadClb a -> GYTxMonadClb () mustFailWith isExpectedError act = do - (st, preFails) <- liftClb $ do - st <- get - preFails <- getFails - pure (st, preFails) - tryError (void act) >>= \case - Left e@(isExpectedError -> True) -> do - gyLogInfo' "" . printf "Successfully caught expected exception %s" $ show e - infoLog <- liftClb $ gets mockInfo - postFails <- liftClb getFails - liftClb $ put - st - { mockInfo = infoLog <> mkMustFailLog preFails postFails - -- , mustFailLog = mkMustFailLog preFails postFails - } - Left err -> liftClb $ logError $ "Action failed with unexpected exception: " ++ show err - Right _ -> liftClb $ logError "Expected action to fail but it succeeds" - where - mkMustFailLog (unLog -> pre) (unLog -> post) = - Log $ second (LogEntry Error . ((msg <> ":") <> ). show) <$> Seq.drop (Seq.length pre) post - msg = "Unnamed failure action" + (st, preFails) <- liftClb $ do + st <- get + preFails <- getFails + pure (st, preFails) + tryError (void act) >>= \case + Left e@(isExpectedError -> True) -> do + gyLogInfo' "" . printf "Successfully caught expected exception %s" $ show e + infoLog <- liftClb $ gets mockInfo + postFails <- liftClb getFails + liftClb $ + put + st + { mockInfo = infoLog <> mkMustFailLog preFails postFails + -- , mustFailLog = mkMustFailLog preFails postFails + } + Left err -> liftClb $ logError $ "Action failed with unexpected exception: " ++ show err + Right _ -> liftClb $ logError "Expected action to fail but it succeeds" + where + mkMustFailLog (unLog -> pre) (unLog -> post) = + Log $ second (LogEntry Error . ((msg <> ":") <>) . show) <$> Seq.drop (Seq.length pre) post + msg = "Unnamed failure action" instance MonadError GYTxMonadException GYTxMonadClb where + throwError = GYTxMonadClb . throwError - throwError = GYTxMonadClb . throwError - - catchError m handler = GYTxMonadClb . catchError (unGYTxMonadClb m) $ unGYTxMonadClb . handler + catchError m handler = GYTxMonadClb . catchError (unGYTxMonadClb m) $ unGYTxMonadClb . handler instance GYTxQueryMonad GYTxMonadClb where - - networkId = do - magic <- liftClb $ gets (mockConfigNetworkId . mockConfig) - -- TODO: Add epoch slots and network era to clb and retrieve from there. - pure . GYPrivnet $ GYNetworkInfo - { gyNetworkMagic = Api.S.unNetworkMagic $ Api.S.toNetworkMagic magic - , gyNetworkEpochSlots = 500 - } - - lookupDatum :: GYDatumHash -> GYTxMonadClb (Maybe GYDatum) - lookupDatum h = liftClb $ do - mdh <- gets mockDatums - return $ do - d <- Map.lookup (datumHashToPlutus h) mdh - return $ datumFromPlutus d - - utxosAtAddress addr mAssetClass = do - gyLogDebug' "" $ "utxosAtAddress, addr: " <> show addr - refs <- liftClb $ txOutRefAt $ addressToApi' addr - gyLogDebug' "" $ "utxosAtAddress, refs: " <> show refs - utxos <- wither f refs - let utxos' = - case mAssetClass of - Nothing -> utxos - Just ac -> filter (\GYUTxO {..} -> valueAssetClass utxoValue ac > 0) utxos - return $ utxosFromList utxos' - where - f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) - f ref = do - case txOutRefFromPlutus ref of - Left _ -> return Nothing -- TODO: should it error? - Right ref' -> utxoAtTxOutRef ref' - - utxosAtPaymentCredential :: GYPaymentCredential -> Maybe GYAssetClass -> GYTxMonadClb GYUTxOs - utxosAtPaymentCredential cred mAssetClass = do - refs <- liftClb $ txOutRefAtPaymentCred $ paymentCredentialToPlutus cred - utxos <- wither f refs - pure - . utxosFromList - $ filter (\GYUTxO{utxoValue} -> maybe True ((> 0) . valueAssetClass utxoValue) mAssetClass) - utxos - where - f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) - f ref = case txOutRefFromPlutus ref of - Left _ -> return Nothing - Right ref' -> utxoAtTxOutRef ref' - - utxoAtTxOutRef ref = do - -- All UTxOs map - utxos <- liftClb $ gets (L.unUTxO . L.S.utxosUtxo . L.S.lsUTxOState . _memPoolState . emulatedLedgerState) - -- Maps keys to Plutus TxOutRef - let m = Map.mapKeys (txOutRefToPlutus . txOutRefFromApi . Api.S.fromShelleyTxIn) utxos - - return $ do - o <- Map.lookup (txOutRefToPlutus ref) m - - let a = addressFromApi . Api.S.fromShelleyAddrToAny . either id L.decompactAddr $ o ^. L.addrEitherTxOutL - v = valueFromApi . Api.S.fromMaryValue . either id L.fromCompact $ o ^. L.valueEitherTxOutL - - d <- case o ^. L.datumTxOutL of - L.NoDatum -> pure GYOutDatumNone - L.DatumHash dh -> GYOutDatumHash <$> rightToMaybe (datumHashFromPlutus $ L.transDataHash dh) - L.Datum binaryData -> pure $ - GYOutDatumInline - . datumFromPlutus - . Plutus.Datum - . Plutus.dataToBuiltinData - . L.getPlutusData - . L.binaryDataToData - $ binaryData - - let s = case o ^. L.referenceScriptTxOutL of - L.S.SJust x -> someScriptFromReferenceApi - $ Api.fromShelleyScriptToReferenceScript Api.ShelleyBasedEraConway x - L.S.SNothing -> Nothing - - return GYUTxO - { utxoRef = ref - , utxoAddress = a - , utxoValue = v - , utxoOutDatum = d - , utxoRefScript = s - } - - stakeAddressInfo = const $ pure Nothing - - slotConfig = do - (zero, len) <- slotConfig' - return $ simpleSlotConfig zero len - - slotOfCurrentBlock = liftClb $ slotFromApi <$> Clb.getCurrentSlot - - logMsg _ns s msg = do - -- let doc = lines msg - let doc = msg - liftClb $ logInfo $ case s of - GYDebug -> LogEntry Debug doc - GYInfo -> LogEntry Info doc - GYWarning -> LogEntry Warning doc - GYError -> LogEntry Error doc - - waitUntilSlot slot = do - -- Silently returns if the given slot is greater than the current slot. - liftClb . Clb.waitSlot $ slotToApi slot - pure slot - waitForNextBlock = slotOfCurrentBlock + networkId = do + magic <- liftClb $ gets (mockConfigNetworkId . mockConfig) + -- TODO: Add epoch slots and network era to clb and retrieve from there. + pure . GYPrivnet $ + GYNetworkInfo + { gyNetworkMagic = Api.S.unNetworkMagic $ Api.S.toNetworkMagic magic + , gyNetworkEpochSlots = 500 + } + + lookupDatum :: GYDatumHash -> GYTxMonadClb (Maybe GYDatum) + lookupDatum h = liftClb $ do + mdh <- gets mockDatums + return $ do + d <- Map.lookup (datumHashToPlutus h) mdh + return $ datumFromPlutus d + + utxosAtAddress addr mAssetClass = do + gyLogDebug' "" $ "utxosAtAddress, addr: " <> show addr + refs <- liftClb $ txOutRefAt $ addressToApi' addr + gyLogDebug' "" $ "utxosAtAddress, refs: " <> show refs + utxos <- wither f refs + let utxos' = + case mAssetClass of + Nothing -> utxos + Just ac -> filter (\GYUTxO {..} -> valueAssetClass utxoValue ac > 0) utxos + return $ utxosFromList utxos' + where + f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) + f ref = do + case txOutRefFromPlutus ref of + Left _ -> return Nothing -- TODO: should it error? + Right ref' -> utxoAtTxOutRef ref' + + utxosAtPaymentCredential :: GYPaymentCredential -> Maybe GYAssetClass -> GYTxMonadClb GYUTxOs + utxosAtPaymentCredential cred mAssetClass = do + refs <- liftClb $ txOutRefAtPaymentCred $ paymentCredentialToPlutus cred + utxos <- wither f refs + pure + . utxosFromList + $ filter + (\GYUTxO {utxoValue} -> maybe True ((> 0) . valueAssetClass utxoValue) mAssetClass) + utxos + where + f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) + f ref = case txOutRefFromPlutus ref of + Left _ -> return Nothing + Right ref' -> utxoAtTxOutRef ref' + + utxoAtTxOutRef ref = do + -- All UTxOs map + utxos <- liftClb $ gets (L.unUTxO . L.S.utxosUtxo . L.S.lsUTxOState . _memPoolState . emulatedLedgerState) + -- Maps keys to Plutus TxOutRef + let m = Map.mapKeys (txOutRefToPlutus . txOutRefFromApi . Api.S.fromShelleyTxIn) utxos + + return $ do + o <- Map.lookup (txOutRefToPlutus ref) m + + let a = addressFromApi . Api.S.fromShelleyAddrToAny . either id L.decompactAddr $ o ^. L.addrEitherTxOutL + v = valueFromApi . Api.S.fromMaryValue . either id L.fromCompact $ o ^. L.valueEitherTxOutL + + d <- case o ^. L.datumTxOutL of + L.NoDatum -> pure GYOutDatumNone + L.DatumHash dh -> GYOutDatumHash <$> rightToMaybe (datumHashFromPlutus $ L.transDataHash dh) + L.Datum binaryData -> + pure + $ GYOutDatumInline + . datumFromPlutus + . Plutus.Datum + . Plutus.dataToBuiltinData + . L.getPlutusData + . L.binaryDataToData + $ binaryData + + let s = case o ^. L.referenceScriptTxOutL of + L.S.SJust x -> + someScriptFromReferenceApi $ + Api.fromShelleyScriptToReferenceScript Api.ShelleyBasedEraConway x + L.S.SNothing -> Nothing + + return + GYUTxO + { utxoRef = ref + , utxoAddress = a + , utxoValue = v + , utxoOutDatum = d + , utxoRefScript = s + } + + stakeAddressInfo = const $ pure Nothing + + slotConfig = do + (zero, len) <- slotConfig' + return $ simpleSlotConfig zero len + + slotOfCurrentBlock = liftClb $ slotFromApi <$> Clb.getCurrentSlot + + logMsg _ns s msg = do + -- let doc = lines msg + let doc = msg + liftClb $ logInfo $ case s of + GYDebug -> LogEntry Debug doc + GYInfo -> LogEntry Info doc + GYWarning -> LogEntry Warning doc + GYError -> LogEntry Error doc + + waitUntilSlot slot = do + -- Silently returns if the given slot is greater than the current slot. + liftClb . Clb.waitSlot $ slotToApi slot + pure slot + waitForNextBlock = slotOfCurrentBlock instance GYTxUserQueryMonad GYTxMonadClb where - - ownAddresses = asks $ userAddresses' . clbEnvWallet - - ownChangeAddress = asks $ userChangeAddress . clbEnvWallet - - ownCollateral = runMaybeT $ do - UserCollateral {userCollateralRef, userCollateralCheck} <- asks (userCollateral . clbEnvWallet) >>= hoistMaybe - collateralUtxo <- lift $ utxoAtTxOutRef userCollateralRef - >>= maybe (throwError . GYQueryUTxOException $ GYNoUtxoAtRef userCollateralRef) pure - if not userCollateralCheck || (utxoValue collateralUtxo == collateralValue) then pure collateralUtxo - else hoistMaybe Nothing - - availableUTxOs = do - addrs <- ownAddresses - utxosAtAddresses addrs - - someUTxO lang = do - addrs <- ownAddresses - utxos <- availableUTxOs - case lang of - PlutusV3 -> ifNotV1 utxos addrs - PlutusV2 -> ifNotV1 utxos addrs - PlutusV1 -> - case find utxoTranslatableToV1 $ utxosToList utxos of - Just u -> return $ utxoRef u - Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Better error message here? - where - ifNotV1 utxos addrs = - case someTxOutRef utxos of - Nothing -> throwError $ GYQueryUTxOException $ GYNoUtxosAtAddress addrs - Just (ref, _) -> return ref + ownAddresses = asks $ userAddresses' . clbEnvWallet + + ownChangeAddress = asks $ userChangeAddress . clbEnvWallet + + ownCollateral = runMaybeT $ do + UserCollateral {userCollateralRef, userCollateralCheck} <- asks (userCollateral . clbEnvWallet) >>= hoistMaybe + collateralUtxo <- + lift $ + utxoAtTxOutRef userCollateralRef + >>= maybe (throwError . GYQueryUTxOException $ GYNoUtxoAtRef userCollateralRef) pure + if not userCollateralCheck || (utxoValue collateralUtxo == collateralValue) + then pure collateralUtxo + else hoistMaybe Nothing + + availableUTxOs = do + addrs <- ownAddresses + utxosAtAddresses addrs + + someUTxO lang = do + addrs <- ownAddresses + utxos <- availableUTxOs + case lang of + PlutusV3 -> ifNotV1 utxos addrs + PlutusV2 -> ifNotV1 utxos addrs + PlutusV1 -> + case find utxoTranslatableToV1 $ utxosToList utxos of + Just u -> return $ utxoRef u + Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Better error message here? + where + ifNotV1 utxos addrs = + case someTxOutRef utxos of + Nothing -> throwError $ GYQueryUTxOException $ GYNoUtxosAtAddress addrs + Just (ref, _) -> return ref instance GYTxMonad GYTxMonadClb where - signTxBody = signTxBodyImpl . asks $ userPaymentSKey . clbEnvWallet - signTxBodyWithStake = signTxBodyWithStakeImpl $ asks ((,) . userPaymentSKey . clbEnvWallet) <*> asks (userStakeSKey . clbEnvWallet) - submitTx tx = do - let txBody = getTxBody tx - dumpBody txBody - gyLogDebug' "" $ "encoded tx: " <> txToHex tx - vRes <- liftClb . sendTx $ txToApi tx - case vRes of - Success _state _onChainTx -> pure $ txBodyTxId txBody - Fail _ err -> throwAppError . someBackendError . T.pack $ show err - where - -- TODO: use Prettyprinter - dumpBody :: GYTxBody -> GYTxMonadClb () - dumpBody body = do - ins <- mapM utxoAtTxOutRef' $ txBodyTxIns body - refIns <- mapM utxoAtTxOutRef' $ txBodyTxInsReference body - gyLogDebug' "" $ - printf "fee: %d lovelace\nmint value: %s\nvalidity range: %s\ncollateral: %s\ntotal collateral: %d\ninputs:\n\n%sreference inputs:\n\n%soutputs:\n\n%s" - (txBodyFee body) - (txBodyMintValue body) - (show $ txBodyValidityRange body) - (show $ txBodyCollateral body) - (txBodyTotalCollateralLovelace body) - (concatMap dumpInUTxO ins) - (concatMap dumpInUTxO refIns) - (concatMap dumpOutUTxO $ utxosToList $ txBodyUTxOs body) - - dumpInUTxO :: GYUTxO -> String - dumpInUTxO GYUTxO{..} = printf " - ref: %s\n" utxoRef <> - printf " addr: %s\n" utxoAddress <> - printf " value: %s\n" utxoValue <> - printf " datum: %s\n" (show utxoOutDatum) <> - printf " ref script: %s\n\n" (show utxoRefScript) - - dumpOutUTxO :: GYUTxO -> String - dumpOutUTxO GYUTxO{..} = printf " - addr: %s\n" utxoAddress <> - printf " value: %s\n" utxoValue <> - printf " datum: %s\n" (show utxoOutDatum) <> - printf " ref script: %s\n\n" (show utxoRefScript) - - -- Transaction submission and confirmation is immediate in CLB. - awaitTxConfirmed' _ _ = pure () + signTxBody = signTxBodyImpl . asks $ userPaymentSKey . clbEnvWallet + signTxBodyWithStake = signTxBodyWithStakeImpl $ asks ((,) . userPaymentSKey . clbEnvWallet) <*> asks (userStakeSKey . clbEnvWallet) + submitTx tx = do + let txBody = getTxBody tx + dumpBody txBody + gyLogDebug' "" $ "encoded tx: " <> txToHex tx + vRes <- liftClb . sendTx $ txToApi tx + case vRes of + Success _state _onChainTx -> pure $ txBodyTxId txBody + Fail _ err -> throwAppError . someBackendError . T.pack $ show err + where + -- TODO: use Prettyprinter + dumpBody :: GYTxBody -> GYTxMonadClb () + dumpBody body = do + ins <- mapM utxoAtTxOutRef' $ txBodyTxIns body + refIns <- mapM utxoAtTxOutRef' $ txBodyTxInsReference body + gyLogDebug' "" $ + printf + "fee: %d lovelace\nmint value: %s\nvalidity range: %s\ncollateral: %s\ntotal collateral: %d\ninputs:\n\n%sreference inputs:\n\n%soutputs:\n\n%s" + (txBodyFee body) + (txBodyMintValue body) + (show $ txBodyValidityRange body) + (show $ txBodyCollateral body) + (txBodyTotalCollateralLovelace body) + (concatMap dumpInUTxO ins) + (concatMap dumpInUTxO refIns) + (concatMap dumpOutUTxO $ utxosToList $ txBodyUTxOs body) + + dumpInUTxO :: GYUTxO -> String + dumpInUTxO GYUTxO {..} = + printf " - ref: %s\n" utxoRef + <> printf " addr: %s\n" utxoAddress + <> printf " value: %s\n" utxoValue + <> printf " datum: %s\n" (show utxoOutDatum) + <> printf " ref script: %s\n\n" (show utxoRefScript) + + dumpOutUTxO :: GYUTxO -> String + dumpOutUTxO GYUTxO {..} = + printf " - addr: %s\n" utxoAddress + <> printf " value: %s\n" utxoValue + <> printf " datum: %s\n" (show utxoOutDatum) + <> printf " ref script: %s\n\n" (show utxoRefScript) + + -- Transaction submission and confirmation is immediate in CLB. + awaitTxConfirmed' _ _ = pure () instance GYTxGameMonad GYTxMonadClb where - type TxMonadOf GYTxMonadClb = GYTxMonadClb - createUser = do - st <- get - let i = clbNextWalletInt st - user = mkSimpleWallet $ Clb.intToKeyPair i - gyLogDebug' "createUser" . T.unpack $ "Created simple user with address: " <> addressToText (userAddr user) - put st { clbNextWalletInt = i + 1 } - pure user - asUser u act = do - -- Overwrite the own user and perform the action. - local - (\x -> x { clbEnvWallet = u }) - act + type TxMonadOf GYTxMonadClb = GYTxMonadClb + createUser = do + st <- get + let i = clbNextWalletInt st + user = mkSimpleWallet $ Clb.intToKeyPair i + gyLogDebug' "createUser" . T.unpack $ "Created simple user with address: " <> addressToText (userAddr user) + put st {clbNextWalletInt = i + 1} + pure user + asUser u act = do + -- Overwrite the own user and perform the action. + local + (\x -> x {clbEnvWallet = u}) + act slotConfig' :: GYTxMonadClb (UTCTime, NominalDiffTime) slotConfig' = liftClb $ do - sc <- gets $ mockConfigSlotConfig . mockConfig - let len = fromInteger (scSlotLength sc) / 1000 - zero = posixSecondsToUTCTime $ timeToPOSIX $ timeFromPlutus $ scSlotZeroTime sc - return (zero, len) + sc <- gets $ mockConfigSlotConfig . mockConfig + let len = fromInteger (scSlotLength sc) / 1000 + zero = posixSecondsToUTCTime $ timeToPOSIX $ timeFromPlutus $ scSlotZeroTime sc + return (zero, len) protocolParameters :: GYTxMonadClb (ConwayCore.PParams (Api.S.ShelleyLedgerEra ApiEra)) protocolParameters = do - pparams <- liftClb $ gets $ mockConfigProtocol . mockConfig - pure $ coerce pparams + pparams <- liftClb $ gets $ mockConfigProtocol . mockConfig + pure $ coerce pparams instance GYTxSpecialQueryMonad GYTxMonadClb where - systemStart = gyscSystemStart <$> slotConfig - - protocolParams = protocolParameters - - stakePools = pure Set.empty - -- stakePools = do - -- pids <- liftClb $ gets $ Map.keys . stake'pools . mockStake - -- foldM f Set.empty pids - -- where - -- f :: Set Api.S.PoolId -> Api.S.PoolId -> GYTxMonadClb (Set Api.S.PoolId) - -- f s pid = either - -- (\e -> throwError $ GYConversionException $ GYLedgerToCardanoError $ DeserialiseRawBytesError ("stakePools, error: " <> fromString (show e))) - -- (\pid' -> return $ Set.insert pid' s) - -- $ Api.deserialiseFromRawBytes (Api.AsHash Api.AsStakePoolKey) bs - -- where - -- Plutus.BuiltinByteString bs = Plutus.getPubKeyHash $ unPoolId pid - - eraHistory = do - (_, len) <- slotConfig' - return $ Api.EraHistory $ eh len - where - eh :: NominalDiffTime -> Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) - eh = Ouroboros.mkInterpreter . Ouroboros.Summary - . NonEmptyCons byronEra - . NonEmptyCons shelleyEra - . NonEmptyCons allegraEra - . NonEmptyCons maryEra - . NonEmptyCons alonzoEra - . NonEmptyCons babbageEra - . NonEmptyOne . conwayEra - - byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} - } - shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - conwayEra len = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength len, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } + systemStart = gyscSystemStart <$> slotConfig + + protocolParams = protocolParameters + + stakePools = pure Set.empty + + -- stakePools = do + -- pids <- liftClb $ gets $ Map.keys . stake'pools . mockStake + -- foldM f Set.empty pids + -- where + -- f :: Set Api.S.PoolId -> Api.S.PoolId -> GYTxMonadClb (Set Api.S.PoolId) + -- f s pid = either + -- (\e -> throwError $ GYConversionException $ GYLedgerToCardanoError $ DeserialiseRawBytesError ("stakePools, error: " <> fromString (show e))) + -- (\pid' -> return $ Set.insert pid' s) + -- $ Api.deserialiseFromRawBytes (Api.AsHash Api.AsStakePoolKey) bs + -- where + -- Plutus.BuiltinByteString bs = Plutus.getPubKeyHash $ unPoolId pid + + eraHistory = do + (_, len) <- slotConfig' + return $ Api.EraHistory $ eh len + where + eh :: NominalDiffTime -> Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) + eh = + Ouroboros.mkInterpreter + . Ouroboros.Summary + . NonEmptyCons byronEra + . NonEmptyCons shelleyEra + . NonEmptyCons allegraEra + . NonEmptyCons maryEra + . NonEmptyCons alonzoEra + . NonEmptyCons babbageEra + . NonEmptyOne + . conwayEra + + byronEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} + } + shelleyEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + allegraEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + maryEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + alonzoEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + babbageEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + conwayEra len = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength len, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } dumpUtxoState :: GYTxMonadClb () dumpUtxoState = liftClb Clb.dumpUtxoState @@ -540,12 +569,12 @@ pureGen :: StdGen pureGen = mkStdGen 42 -- | This is simply defined as @buildTxBody skeleton >>= signAndSubmitConfirmed@. -sendSkeleton :: GYTxMonad m => GYTxSkeleton v -> m GYTxId +sendSkeleton :: (GYTxMonad m) => GYTxSkeleton v -> m GYTxId sendSkeleton skeleton = snd <$> sendSkeleton' skeleton -sendSkeleton' :: GYTxMonad m => GYTxSkeleton v -> m (GYTxBody, GYTxId) +sendSkeleton' :: (GYTxMonad m) => GYTxSkeleton v -> m (GYTxBody, GYTxId) sendSkeleton' skeleton = buildTxBody skeleton >>= \tx -> signAndSubmitConfirmed tx >>= \txId -> pure (tx, txId) -- | Variant of `logInfo` from @Clb@ that logs a string with @Info@ severity. -logInfoS :: Monad m => String -> ClbT ApiEra m () +logInfoS :: (Monad m) => String -> ClbT ApiEra m () logInfoS s = Clb.logInfo $ Clb.LogEntry Clb.Info s diff --git a/src/GeniusYield/Test/FakeCoin.hs b/src/GeniusYield/Test/FakeCoin.hs index 13a30756..2c019472 100644 --- a/src/GeniusYield/Test/FakeCoin.hs +++ b/src/GeniusYield/Test/FakeCoin.hs @@ -1,22 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} - {-# OPTIONS -fno-strictness -fno-spec-constr -fno-specialise #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} module GeniusYield.Test.FakeCoin (FakeCoin (..), fakeValue, fakeCoin, fakePolicy) where -import PlutusCore.Core (plcVersion100) -import qualified PlutusLedgerApi.V1.Value as PlutusValue -import PlutusLedgerApi.V2 -import PlutusLedgerApi.V2.Contexts (ownCurrencySymbol) -import qualified PlutusTx -import PlutusTx.Prelude +import PlutusCore.Core (plcVersion100) +import PlutusLedgerApi.V1.Value qualified as PlutusValue +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V2.Contexts (ownCurrencySymbol) +import PlutusTx qualified +import PlutusTx.Prelude -import GeniusYield.Types +import GeniusYield.Types -- | Test assets. -newtype FakeCoin = FakeCoin { fakeCoinName :: GYTokenName } +newtype FakeCoin = FakeCoin {fakeCoinName :: GYTokenName} fakePolicy :: FakeCoin -> GYMintingPolicy PlutusV2 fakePolicy = fakeMintingPolicy . fakeCoinName @@ -33,7 +32,7 @@ fakeMintingPolicy = mintingPolicyFromPlutus . fakeMintingPolicyPlutus . tokenNam fakeMintingPolicyPlutus :: TokenName -> PlutusTx.CompiledCode (BuiltinData -> BuiltinData -> ()) fakeMintingPolicyPlutus mintParam = - $$(PlutusTx.compile [|| fakeMintingPolicyUntypedContract ||]) `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 mintParam + $$(PlutusTx.compile [||fakeMintingPolicyUntypedContract||]) `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 mintParam -- | Can mint new coins if token name equals to fixed tag. {-# INLINEABLE fakeMintingPolicyContract #-} diff --git a/src/GeniusYield/Test/FeeTracker.hs b/src/GeniusYield/Test/FeeTracker.hs index 51c8a79a..c5a76de5 100644 --- a/src/GeniusYield/Test/FeeTracker.hs +++ b/src/GeniusYield/Test/FeeTracker.hs @@ -1,12 +1,10 @@ -{-| +{- | Module : GeniusYield.Test.FeeTracker Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} - module GeniusYield.Test.FeeTracker ( FeeTrackerGame, FeeTracker, @@ -14,168 +12,175 @@ module GeniusYield.Test.FeeTracker ( ftLift, withWalletBalancesCheckSimple, withWalletBalancesCheckSimpleIgnoreMinDepFor, - withoutFeeTracking + withoutFeeTracking, ) where -import Control.Monad.Except -import Control.Monad.Random -import Control.Monad.State.Strict -import Data.Foldable (foldMap') -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as M -import Data.Monoid -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LTE - -import qualified Data.Aeson as Aeson - -import GeniusYield.HTTP.Errors (someBackendError) -import GeniusYield.Imports -import GeniusYield.TxBuilder -import GeniusYield.Types +import Control.Monad.Except +import Control.Monad.Random +import Control.Monad.State.Strict +import Data.Foldable (foldMap') +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as M +import Data.Monoid +import Data.Set qualified as S +import Data.Text qualified as T +import Data.Text.Lazy qualified as LT +import Data.Text.Lazy.Encoding qualified as LTE + +import Data.Aeson qualified as Aeson + +import GeniusYield.HTTP.Errors (someBackendError) +import GeniusYield.Imports +import GeniusYield.TxBuilder +import GeniusYield.Types type FeesLovelace = Sum Integer type MinAdaLovelace = Sum Integer -- | Extra lovelaces that were gained or lost by a user which a smart contract need not be expecting. data UserExtraLovelace = UserExtraLovelace - { uelFees :: !FeesLovelace - -- ^ Lovelaces lost to fees. - , uelMinAda :: !MinAdaLovelace - -- ^ Lovelaces lost to min ada deposit(s). - -- Also takes into account any min ada deposit _gained_ from utxo(s). - } + { uelFees :: !FeesLovelace + -- ^ Lovelaces lost to fees. + , uelMinAda :: !MinAdaLovelace + -- ^ Lovelaces lost to min ada deposit(s). + -- Also takes into account any min ada deposit _gained_ from utxo(s). + } deriving stock (Eq, Ord, Show) instance Semigroup UserExtraLovelace where - UserExtraLovelace a b <> UserExtraLovelace x y = UserExtraLovelace (a <> x) (b <> y) + UserExtraLovelace a b <> UserExtraLovelace x y = UserExtraLovelace (a <> x) (b <> y) instance Monoid UserExtraLovelace where - mempty = UserExtraLovelace mempty mempty + mempty = UserExtraLovelace mempty mempty --- | Track extra lovelace per user. --- Note: This does the tracking during transaction building. --- If you do not wish to submit said transaction, you should not have it tracked. --- Use 'withoutFeeTracking' etc in those cases. -newtype FeeTrackerState = FeeTrackerState { feesPerUser :: Map GYPubKeyHash UserExtraLovelace } +{- | Track extra lovelace per user. +Note: This does the tracking during transaction building. +If you do not wish to submit said transaction, you should not have it tracked. +Use 'withoutFeeTracking' etc in those cases. +-} +newtype FeeTrackerState = FeeTrackerState {feesPerUser :: Map GYPubKeyHash UserExtraLovelace} deriving stock (Eq, Ord, Show) instance Semigroup FeeTrackerState where - FeeTrackerState fees <> FeeTrackerState fees' = FeeTrackerState (M.unionWith (<>) fees fees') + FeeTrackerState fees <> FeeTrackerState fees' = FeeTrackerState (M.unionWith (<>) fees fees') instance Monoid FeeTrackerState where - mempty = FeeTrackerState mempty + mempty = FeeTrackerState mempty stSingleton :: GYPubKeyHash -> UserExtraLovelace -> FeeTrackerState stSingleton k = FeeTrackerState . M.singleton k -- | A wrapper around 'GYTxMonad' that "injects" code around transaction building and submitting to track fees. newtype FeeTracker m a = FeeTracker (FeeTrackerState -> m (a, FeeTrackerState)) - deriving ( Functor - , Applicative - , Monad - , MonadState FeeTrackerState - , MonadRandom - , GYTxQueryMonad - , GYTxSpecialQueryMonad - , GYTxUserQueryMonad - , GYTxMonad - ) - via StateT FeeTrackerState m + deriving + ( Functor + , Applicative + , Monad + , MonadState FeeTrackerState + , MonadRandom + , GYTxQueryMonad + , GYTxSpecialQueryMonad + , GYTxUserQueryMonad + , GYTxMonad + ) + via StateT FeeTrackerState m -- The context cannot be inferred since it contains non-type variables (i.e 'GYTxMonadException') -- Must use standalone deriving with explicit context. -deriving - via StateT FeeTrackerState m - instance MonadError GYTxMonadException m => MonadError GYTxMonadException (FeeTracker m) +deriving via + StateT FeeTrackerState m + instance + (MonadError GYTxMonadException m) => MonadError GYTxMonadException (FeeTracker m) -- | Perform a special action supported by the specific wrapped monad instance by lifting it to 'FeeTracker'. -ftLift :: Functor m => m a -> FeeTracker m a -ftLift act = FeeTracker $ \s -> (, s) <$> act +ftLift :: (Functor m) => m a -> FeeTracker m a +ftLift act = FeeTracker $ \s -> (,s) <$> act -- | Override given transaction building function to track extra lovelace per transaction. -wrapBodyBuilder :: GYTxUserQueryMonad m => ([GYTxSkeleton v] -> m GYTxBuildResult) -> [GYTxSkeleton v] -> FeeTracker m GYTxBuildResult +wrapBodyBuilder :: (GYTxUserQueryMonad m) => ([GYTxSkeleton v] -> m GYTxBuildResult) -> [GYTxSkeleton v] -> FeeTracker m GYTxBuildResult wrapBodyBuilder f skeletons = do - ownPkh <- ownChangeAddress >>= addressToPubKeyHash' - res <- ftLift $ f skeletons - let helpers txBodies = forM_ (zip skeletons (NE.toList txBodies)) (helper ownPkh) - case res of - GYTxBuildSuccess txBodies -> helpers txBodies - GYTxBuildPartialSuccess _ txBodies -> helpers txBodies - _ -> pure () - pure res + ownPkh <- ownChangeAddress >>= addressToPubKeyHash' + res <- ftLift $ f skeletons + let helpers txBodies = forM_ (zip skeletons (NE.toList txBodies)) (helper ownPkh) + case res of + GYTxBuildSuccess txBodies -> helpers txBodies + GYTxBuildPartialSuccess _ txBodies -> helpers txBodies + _ -> pure () + pure res where helper ownPkh (skeleton, txBody) = do - -- Actual outputs with their blueprints (counterpart from skeleton) - -- NOTE: This relies on proper ordering. 'txBodyUTxOs txBody' is expected to have the same order - -- as the outputs in the skeleton. The extra balancing outputs at the end of the list of 'txBodyUTxOs txBody' - -- should be truncated by 'zip'. - let outsWithBlueprint = zip (gytxOuts skeleton) . utxosToList $ txBodyUTxOs txBody - feeExtraLovelace = stSingleton ownPkh mempty { uelFees = Sum $ txBodyFee txBody } - depositsExtraLovelace = foldMap' - (\(blueprint, actual) -> - let targetAddr = gyTxOutAddress blueprint - deposit = Sum . flip valueAssetClass GYLovelace $ utxoValue actual `valueMinus` gyTxOutValue blueprint - -- These two will cancel out if the ada is going to own address. - ownLostDeposit = stSingleton ownPkh mempty { uelMinAda = deposit } - otherGainedDeposit = maybe mempty (`stSingleton` mempty { uelMinAda = negate deposit }) $ addressToPubKeyHash targetAddr - in ownLostDeposit <> otherGainedDeposit - ) - outsWithBlueprint - modify' (\prev -> prev <> feeExtraLovelace <> depositsExtraLovelace) + -- Actual outputs with their blueprints (counterpart from skeleton) + -- NOTE: This relies on proper ordering. 'txBodyUTxOs txBody' is expected to have the same order + -- as the outputs in the skeleton. The extra balancing outputs at the end of the list of 'txBodyUTxOs txBody' + -- should be truncated by 'zip'. + let outsWithBlueprint = zip (gytxOuts skeleton) . utxosToList $ txBodyUTxOs txBody + feeExtraLovelace = stSingleton ownPkh mempty {uelFees = Sum $ txBodyFee txBody} + depositsExtraLovelace = + foldMap' + ( \(blueprint, actual) -> + let targetAddr = gyTxOutAddress blueprint + deposit = Sum . flip valueAssetClass GYLovelace $ utxoValue actual `valueMinus` gyTxOutValue blueprint + -- These two will cancel out if the ada is going to own address. + ownLostDeposit = stSingleton ownPkh mempty {uelMinAda = deposit} + otherGainedDeposit = maybe mempty (`stSingleton` mempty {uelMinAda = negate deposit}) $ addressToPubKeyHash targetAddr + in ownLostDeposit <> otherGainedDeposit + ) + outsWithBlueprint + modify' (\prev -> prev <> feeExtraLovelace <> depositsExtraLovelace) -- | Override transaction building code of the inner monad to track extra lovelace per transaction. -instance GYTxBuilderMonad m => GYTxBuilderMonad (FeeTracker m) where - type TxBuilderStrategy (FeeTracker m) = TxBuilderStrategy m - buildTxBodyWithStrategy strat skeleton = do - res <- wrapBodyBuilder (\x -> GYTxBuildSuccess . NE.singleton <$> buildTxBodyWithStrategy @m strat (head x)) [skeleton] - case res of - GYTxBuildSuccess bodies -> pure $ NE.head bodies - _ -> error "FeeTracker.buildTxBodyWithStrategy: Absurd" - buildTxBodyParallelWithStrategy strat = wrapBodyBuilder $ buildTxBodyParallelWithStrategy strat - buildTxBodyChainingWithStrategy strat = wrapBodyBuilder $ buildTxBodyChainingWithStrategy strat - --- | Run an action and ignore any tracked fees. --- Useful for building a tx body without the intent to submit it later. Thereby ignoring all the tracked fees --- from that txbody that won't actually take effect in the wallet (since it won't be submitted). -withoutFeeTracking :: Monad m => FeeTracker m a -> FeeTracker m a +instance (GYTxBuilderMonad m) => GYTxBuilderMonad (FeeTracker m) where + type TxBuilderStrategy (FeeTracker m) = TxBuilderStrategy m + buildTxBodyWithStrategy strat skeleton = do + res <- wrapBodyBuilder (\x -> GYTxBuildSuccess . NE.singleton <$> buildTxBodyWithStrategy @m strat (head x)) [skeleton] + case res of + GYTxBuildSuccess bodies -> pure $ NE.head bodies + _ -> error "FeeTracker.buildTxBodyWithStrategy: Absurd" + buildTxBodyParallelWithStrategy strat = wrapBodyBuilder $ buildTxBodyParallelWithStrategy strat + buildTxBodyChainingWithStrategy strat = wrapBodyBuilder $ buildTxBodyChainingWithStrategy strat + +{- | Run an action and ignore any tracked fees. +Useful for building a tx body without the intent to submit it later. Thereby ignoring all the tracked fees +from that txbody that won't actually take effect in the wallet (since it won't be submitted). +-} +withoutFeeTracking :: (Monad m) => FeeTracker m a -> FeeTracker m a withoutFeeTracking act = do - s <- get - a <- act - put s - pure a + s <- get + a <- act + put s + pure a -- | A wrapper around 'GYTxGameMonad' that uses 'FeeTracker' as its 'GYTxMonad' to track extra lovelaces per transaction. newtype FeeTrackerGame m a = FeeTrackerGame (FeeTrackerState -> m (a, FeeTrackerState)) - deriving ( Functor - , Applicative - , Monad - , MonadState FeeTrackerState - , MonadRandom - , GYTxQueryMonad - , GYTxSpecialQueryMonad - ) - via StateT FeeTrackerState m + deriving + ( Functor + , Applicative + , Monad + , MonadState FeeTrackerState + , MonadRandom + , GYTxQueryMonad + , GYTxSpecialQueryMonad + ) + via StateT FeeTrackerState m -- The context cannot be inferred since it contains non-type variables (i.e 'GYTxMonadException') -- Must use standalone deriving with explicit context. -deriving - via StateT FeeTrackerState m - instance MonadError GYTxMonadException m => MonadError GYTxMonadException (FeeTrackerGame m) +deriving via + StateT FeeTrackerState m + instance + (MonadError GYTxMonadException m) => MonadError GYTxMonadException (FeeTrackerGame m) -evalFtg :: Functor f => FeeTrackerGame f b -> f b +evalFtg :: (Functor f) => FeeTrackerGame f b -> f b evalFtg (FeeTrackerGame act) = fst <$> act mempty -- | Perform a special action supported by the specific wrapped monad instance by lifting it to 'FeeTrackerGame'. -ftgLift :: Functor m => m a -> FeeTrackerGame m a -ftgLift act = FeeTrackerGame $ \s -> (, s) <$> act +ftgLift :: (Functor m) => m a -> FeeTrackerGame m a +ftgLift act = FeeTrackerGame $ \s -> (,s) <$> act -instance GYTxGameMonad m => GYTxGameMonad (FeeTrackerGame m) where - type TxMonadOf (FeeTrackerGame m) = FeeTracker (TxMonadOf m) - createUser = ftgLift createUser - asUser u (FeeTracker act) = FeeTrackerGame $ asUser u . act +instance (GYTxGameMonad m) => GYTxGameMonad (FeeTrackerGame m) where + type TxMonadOf (FeeTrackerGame m) = FeeTracker (TxMonadOf m) + createUser = ftgLift createUser + asUser u (FeeTracker act) = FeeTrackerGame $ asUser u . act {- Note [Proper GYTxMonad overriding with FeeTracker] @@ -207,40 +212,40 @@ Notes: * An empty list means no checks are performed. * The 'GYValue' should be negative to check if the Wallet lost those funds. -} -withWalletBalancesCheckSimple :: GYTxGameMonad m => [(User, GYValue)] -> FeeTrackerGame m a -> m a +withWalletBalancesCheckSimple :: (GYTxGameMonad m) => [(User, GYValue)] -> FeeTrackerGame m a -> m a withWalletBalancesCheckSimple wallValueDiffs = withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs mempty -- | Variant of `withWalletBalancesCheckSimple` that only accounts for transaction fees and not minimum ada deposits. -withWalletBalancesCheckSimpleIgnoreMinDepFor :: GYTxGameMonad m => [(User, GYValue)] -> Set User -> FeeTrackerGame m a -> m a +withWalletBalancesCheckSimpleIgnoreMinDepFor :: (GYTxGameMonad m) => [(User, GYValue)] -> Set User -> FeeTrackerGame m a -> m a withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs ignoreMinDepFor m = evalFtg $ do - bs <- mapM (queryBalances . userAddresses' . fst) wallValueDiffs - a <- m - walletExtraLovelaceMap <- gets feesPerUser - bs' <- mapM (queryBalances . userAddresses' . fst) wallValueDiffs - - forM_ (zip3 wallValueDiffs bs' bs) $ - \((w, v), b', b) -> - let pkh = userPkh w - newBalance = case M.lookup pkh walletExtraLovelaceMap of - Nothing -> b' - Just UserExtraLovelace {uelFees, uelMinAda} -> b' <> valueFromLovelace (getSum $ uelFees <> if w `S.member` ignoreMinDepFor then mempty else uelMinAda) - diff = newBalance `valueMinus` b - in unless (diff == v) . throwAppError . someBackendError . T.pack $ + bs <- mapM (queryBalances . userAddresses' . fst) wallValueDiffs + a <- m + walletExtraLovelaceMap <- gets feesPerUser + bs' <- mapM (queryBalances . userAddresses' . fst) wallValueDiffs + + forM_ (zip3 wallValueDiffs bs' bs) $ + \((w, v), b', b) -> + let pkh = userPkh w + newBalance = case M.lookup pkh walletExtraLovelaceMap of + Nothing -> b' + Just UserExtraLovelace {uelFees, uelMinAda} -> b' <> valueFromLovelace (getSum $ uelFees <> if w `S.member` ignoreMinDepFor then mempty else uelMinAda) + diff = newBalance `valueMinus` b + in unless (diff == v) . throwAppError . someBackendError . T.pack $ printf - ( "Wallet PKH: %s.\n" - ++ "Old balance: %s.\n" - ++ "New balance: %s.\n" - ++ "New balance after adding extra lovelaces %s.\n" - ++ " Expected balance difference of: %s\n" - ++ " But the actual difference was: %s" - ) - (encodeJsonText pkh) - (encodeJsonText b) - (encodeJsonText b') - (encodeJsonText newBalance) - (encodeJsonText v) - (encodeJsonText diff) - pure a + ( "Wallet PKH: %s.\n" + ++ "Old balance: %s.\n" + ++ "New balance: %s.\n" + ++ "New balance after adding extra lovelaces %s.\n" + ++ " Expected balance difference of: %s\n" + ++ " But the actual difference was: %s" + ) + (encodeJsonText pkh) + (encodeJsonText b) + (encodeJsonText b') + (encodeJsonText newBalance) + (encodeJsonText v) + (encodeJsonText diff) + pure a where - encodeJsonText :: ToJSON a => a -> Text + encodeJsonText :: (ToJSON a) => a -> Text encodeJsonText = LT.toStrict . LTE.decodeUtf8 . Aeson.encode diff --git a/src/GeniusYield/Test/Privnet/Asserts.hs b/src/GeniusYield/Test/Privnet/Asserts.hs index c5df5d0b..83bb99a6 100644 --- a/src/GeniusYield/Test/Privnet/Asserts.hs +++ b/src/GeniusYield/Test/Privnet/Asserts.hs @@ -1,61 +1,66 @@ -{-| +{- | Module : GeniusYield.Test.Privnet.Asserts Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Test.Privnet.Asserts ( - assertBool, - assertEqual, - assertFailure, - assertFee, - assertThrown, - assertUserFunds, - isTxBodyErrorAutoBalance, + assertBool, + assertEqual, + assertFailure, + assertFee, + assertThrown, + assertUserFunds, + isTxBodyErrorAutoBalance, ) where -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Typeable (typeRep) -import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Typeable (typeRep) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure) -import GeniusYield.Imports -import GeniusYield.Transaction -import GeniusYield.TxBuilder.Errors -import GeniusYield.Types +import GeniusYield.Imports +import GeniusYield.Transaction +import GeniusYield.TxBuilder.Errors +import GeniusYield.Types -import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Ctx -assertFee :: HasCallStack => GYTxBody -> Integer -> Integer -> IO () +assertFee :: (HasCallStack) => GYTxBody -> Integer -> Integer -> IO () assertFee (txBodyFee -> fee) lb ub - | fee < lb = assertFailure $ printf "Fee: %d less than %d" fee lb - | fee > ub = assertFailure $ printf "Fee: %d greater than %d" fee ub - | otherwise = return () + | fee < lb = assertFailure $ printf "Fee: %d less than %d" fee lb + | fee > ub = assertFailure $ printf "Fee: %d greater than %d" fee ub + | otherwise = return () -assertThrown :: forall e a . Exception e => (e -> Bool) -> IO a -> IO () +assertThrown :: forall e a. (Exception e) => (e -> Bool) -> IO a -> IO () assertThrown p action = do - thrownRef <- newIORef False - void action `catch` \ e -> - if p e - then writeIORef thrownRef True - else assertFailure $ "Exception doesn't match predicate: " ++ name - - thrown <- readIORef thrownRef - unless thrown $ assertFailure $ "Expecting an exception: " ++ name + thrownRef <- newIORef False + void action `catch` \e -> + if p e + then writeIORef thrownRef True + else assertFailure $ "Exception doesn't match predicate: " ++ name + + thrown <- readIORef thrownRef + unless thrown $ assertFailure $ "Expecting an exception: " ++ name where name = show (typeRep (Proxy @e)) -- | Asserts if the user funds change as expected. This function subtracts fees from the given expected value. assertUserFunds :: Integer -> Ctx -> User -> GYValue -> IO () assertUserFunds fees ctx u expectedValue = do - currentValue <- ctxQueryBalance ctx u - let expectedValue' = expectedValue `valueMinus` valueFromLovelace fees - assertBool (unwords ["The value didn't change as expected", - "\nExpected: ", show expectedValue', - "\nCurrent: ", show currentValue]) - (currentValue == expectedValue') + currentValue <- ctxQueryBalance ctx u + let expectedValue' = expectedValue `valueMinus` valueFromLovelace fees + assertBool + ( unwords + [ "The value didn't change as expected" + , "\nExpected: " + , show expectedValue' + , "\nCurrent: " + , show currentValue + ] + ) + (currentValue == expectedValue') isTxBodyErrorAutoBalance :: GYTxMonadException -> Bool isTxBodyErrorAutoBalance (GYBuildTxException (GYBuildTxBodyErrorAutoBalance _)) = True -isTxBodyErrorAutoBalance _ = False +isTxBodyErrorAutoBalance _ = False diff --git a/src/GeniusYield/Test/Privnet/Ctx.hs b/src/GeniusYield/Test/Privnet/Ctx.hs index 26beaf77..7c4a36cb 100644 --- a/src/GeniusYield/Test/Privnet/Ctx.hs +++ b/src/GeniusYield/Test/Privnet/Ctx.hs @@ -1,119 +1,130 @@ -{-| +{- | Module : GeniusYield.Test.Privnet.Ctx Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Test.Privnet.Ctx ( - -- * Context - Ctx (..), - ctxNetworkId, - -- * User - User (..), - CreateUserConfig (..), - ctxUsers, - ctxWallets, - userPkh, - userPaymentPkh, - userStakePkh, - userVKey, - userPaymentVKey, - userStakeVKey, - -- * Operations - ctxRunGame, - ctxRun, - ctxRunQuery, - ctxRunBuilder, - ctxRunBuilderWithCollateral, - ctxSlotOfCurrentBlock, - ctxWaitNextBlock, - ctxWaitUntilSlot, - ctxProviders, - ctxSlotConfig, - -- * Helpers - newTempUserCtx, - ctxQueryBalance, - findOutput, + -- * Context + Ctx (..), + ctxNetworkId, + + -- * User + User (..), + CreateUserConfig (..), + ctxUsers, + ctxWallets, + userPkh, + userPaymentPkh, + userStakePkh, + userVKey, + userPaymentVKey, + userStakeVKey, + + -- * Operations + ctxRunGame, + ctxRun, + ctxRunQuery, + ctxRunBuilder, + ctxRunBuilderWithCollateral, + ctxSlotOfCurrentBlock, + ctxWaitNextBlock, + ctxWaitUntilSlot, + ctxProviders, + ctxSlotConfig, + + -- * Helpers + newTempUserCtx, + ctxQueryBalance, + findOutput, ) where -import qualified Cardano.Api as Api -import Data.Default (Default (..)) -import GeniusYield.Imports -import GeniusYield.Providers.Node -import GeniusYield.TxBuilder -import GeniusYield.Types -import GeniusYield.Test.Utils -import Test.Tasty.HUnit (assertFailure) +import Cardano.Api qualified as Api +import Data.Default (Default (..)) +import GeniusYield.Imports +import GeniusYield.Providers.Node +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types +import Test.Tasty.HUnit (assertFailure) -- TODO (simplify-genesis): Remove this once 'newTempUserCtx' has been removed. -data CreateUserConfig = - CreateUserConfig - { -- | Create collateral output of 5 ada? - cucGenerateCollateral :: !Bool, - -- | Create a stake key for the user? - cucGenerateStakeKey :: !Bool - } +data CreateUserConfig + = CreateUserConfig + { cucGenerateCollateral :: !Bool + -- ^ Create collateral output of 5 ada? + , cucGenerateStakeKey :: !Bool + -- ^ Create a stake key for the user? + } instance Default CreateUserConfig where - def = CreateUserConfig { cucGenerateCollateral = False, cucGenerateStakeKey = False } - + def = CreateUserConfig {cucGenerateCollateral = False, cucGenerateStakeKey = False} data Ctx = Ctx - { ctxNetworkInfo :: !GYNetworkInfo - , ctxInfo :: !Api.LocalNodeConnectInfo - -- FIXME: There are now multiple genesis users (since cardano-testnet usage). + { ctxNetworkInfo :: !GYNetworkInfo + , ctxInfo :: !Api.LocalNodeConnectInfo + , -- FIXME: There are now multiple genesis users (since cardano-testnet usage). -- TODO (simplify-genesis): Remove these fields (except for funder user(s)) -- once user creation logic is removed from test setup. - , ctxUserF :: !User -- ^ Funder. All other users begin with same status of funds. - , ctxUser2 :: !User - , ctxUser3 :: !User - , ctxUser4 :: !User - , ctxUser5 :: !User - , ctxUser6 :: !User - , ctxUser7 :: !User - , ctxUser8 :: !User - , ctxUser9 :: !User - , ctxGold :: !GYAssetClass -- ^ asset used in tests - , ctxIron :: !GYAssetClass -- ^ asset used in tests - , ctxLog :: !GYLogConfiguration - , ctxLookupDatum :: !GYLookupDatum - , ctxAwaitTxConfirmed :: !GYAwaitTx - , ctxQueryUtxos :: !GYQueryUTxO - , ctxGetParams :: !GYGetParameters - } + ctxUserF :: !User + -- ^ Funder. All other users begin with same status of funds. + , ctxUser2 :: !User + , ctxUser3 :: !User + , ctxUser4 :: !User + , ctxUser5 :: !User + , ctxUser6 :: !User + , ctxUser7 :: !User + , ctxUser8 :: !User + , ctxUser9 :: !User + , ctxGold :: !GYAssetClass + -- ^ asset used in tests + , ctxIron :: !GYAssetClass + -- ^ asset used in tests + , ctxLog :: !GYLogConfiguration + , ctxLookupDatum :: !GYLookupDatum + , ctxAwaitTxConfirmed :: !GYAwaitTx + , ctxQueryUtxos :: !GYQueryUTxO + , ctxGetParams :: !GYGetParameters + } ctxNetworkId :: Ctx -> GYNetworkId ctxNetworkId Ctx {ctxNetworkInfo} = GYPrivnet ctxNetworkInfo -- TODO (simplify-genesis): Remove this once user creation logic is removed from test setup. --- | List of context sibling users - all of which begin with same balance. --- FIXME: Some of these users are actually genesis users. + +{- | List of context sibling users - all of which begin with same balance. +FIXME: Some of these users are actually genesis users. +-} ctxUsers :: Ctx -> [User] ctxUsers ctx = ($ ctx) <$> [ctxUser2, ctxUser3, ctxUser4, ctxUser5, ctxUser6, ctxUser7, ctxUser8, ctxUser9] -- TODO (simplify-genesis): Remove this once user creation logic is removed from test setup. ctxWallets :: Ctx -> Wallets -ctxWallets Ctx{..} = Wallets - { w1 = ctxUserF - , w2 = ctxUser2 - , w3 = ctxUser3 - , w4 = ctxUser4 - , w5 = ctxUser5 - , w6 = ctxUser6 - , w7 = ctxUser7 - , w8 = ctxUser8 - , w9 = ctxUser9 - } +ctxWallets Ctx {..} = + Wallets + { w1 = ctxUserF + , w2 = ctxUser2 + , w3 = ctxUser3 + , w4 = ctxUser4 + , w5 = ctxUser5 + , w6 = ctxUser6 + , w7 = ctxUser7 + , w8 = ctxUser8 + , w9 = ctxUser9 + } -- TODO (simplify-genesis): Remove this. See note 'simplify-genesis'. + -- | Creates a new user with the given balance. Note that the actual balance which this user get's could be more than what is provided to satisfy minimum ada requirement of a UTxO. -newTempUserCtx:: Ctx - -> User -- ^ User which will fund this new user. - -> GYValue -- ^ Describes balance of new user. - -> CreateUserConfig - -> IO User +newTempUserCtx :: + Ctx -> + -- | User which will fund this new user. + User -> + -- | Describes balance of new user. + GYValue -> + CreateUserConfig -> + IO User newTempUserCtx ctx fundUser fundValue CreateUserConfig {..} = do newPaymentSKey <- generatePaymentSigningKey newStakeSKey <- if cucGenerateStakeKey then Just <$> generateStakeSigningKey else pure Nothing @@ -129,12 +140,14 @@ newTempUserCtx ctx fundUser fundValue CreateUserConfig {..} = do when (cucGenerateCollateral && adaInValue < collateralLovelace) $ fail "Given value for new user has less than 5 ada" ctxRun ctx fundUser $ do - txBody <- buildTxBody $ - if cucGenerateCollateral then - mustHaveOutput (mkGYTxOutNoDatum newAddr (otherValue <> (valueFromLovelace adaInValue `valueMinus` collateralValue))) <> - mustHaveOutput (mkGYTxOutNoDatum newAddr collateralValue) - else - mustHaveOutput (mkGYTxOutNoDatum newAddr fundValue) + txBody <- + buildTxBody $ + if cucGenerateCollateral + then + mustHaveOutput (mkGYTxOutNoDatum newAddr (otherValue <> (valueFromLovelace adaInValue `valueMinus` collateralValue))) + <> mustHaveOutput (mkGYTxOutNoDatum newAddr collateralValue) + else + mustHaveOutput (mkGYTxOutNoDatum newAddr fundValue) signAndSubmitConfirmed_ txBody pure $ User' {userPaymentSKey' = newPaymentSKey, userAddr = newAddr, userStakeSKey' = newStakeSKey} @@ -152,13 +165,17 @@ ctxRunBuilder :: Ctx -> User -> GYTxBuilderMonadIO a -> IO a ctxRunBuilder ctx User' {..} = runGYTxBuilderMonadIO (ctxNetworkId ctx) (ctxProviders ctx) [userAddr] userAddr Nothing -- | Variant of `ctxRun` where caller can also give the UTxO to be used as collateral. -ctxRunBuilderWithCollateral :: Ctx - -> User - -> GYTxOutRef -- ^ Reference to UTxO to be used as collateral. - -> Bool -- ^ To check whether this given collateral UTxO has value of exact 5 ada? If it doesn't have exact 5 ada, it would be ignored. - -> GYTxBuilderMonadIO a - -> IO a -ctxRunBuilderWithCollateral ctx User' {..} coll toCheck5Ada = runGYTxBuilderMonadIO +ctxRunBuilderWithCollateral :: + Ctx -> + User -> + -- | Reference to UTxO to be used as collateral. + GYTxOutRef -> + -- | To check whether this given collateral UTxO has value of exact 5 ada? If it doesn't have exact 5 ada, it would be ignored. + Bool -> + GYTxBuilderMonadIO a -> + IO a +ctxRunBuilderWithCollateral ctx User' {..} coll toCheck5Ada = + runGYTxBuilderMonadIO (ctxNetworkId ctx) (ctxProviders ctx) [userAddr] @@ -167,7 +184,7 @@ ctxRunBuilderWithCollateral ctx User' {..} coll toCheck5Ada = runGYTxBuilderMona ctxSlotOfCurrentBlock :: Ctx -> IO GYSlot ctxSlotOfCurrentBlock (ctxProviders -> providers) = - gyGetSlotOfCurrentBlock providers + gyGetSlotOfCurrentBlock providers ctxWaitNextBlock :: Ctx -> IO () ctxWaitNextBlock (ctxProviders -> providers) = void $ gyWaitForNextBlock providers @@ -180,23 +197,25 @@ ctxSlotConfig ctx = ctxRunQuery ctx slotConfig ctxQueryBalance :: Ctx -> User -> IO GYValue ctxQueryBalance ctx u = ctxRunQuery ctx $ do - queryBalance $ userAddr u + queryBalance $ userAddr u ctxProviders :: Ctx -> GYProviders -ctxProviders ctx = GYProviders - { gyLookupDatum = ctxLookupDatum ctx - , gySubmitTx = nodeSubmitTx (ctxInfo ctx) +ctxProviders ctx = + GYProviders + { gyLookupDatum = ctxLookupDatum ctx + , gySubmitTx = nodeSubmitTx (ctxInfo ctx) , gyAwaitTxConfirmed = ctxAwaitTxConfirmed ctx - , gySlotActions = nodeSlotActions (ctxInfo ctx) - , gyGetParameters = ctxGetParams ctx - , gyQueryUTxO = ctxQueryUtxos ctx - , gyLog' = ctxLog ctx + , gySlotActions = nodeSlotActions (ctxInfo ctx) + , gyGetParameters = ctxGetParams ctx + , gyQueryUTxO = ctxQueryUtxos ctx + , gyLog' = ctxLog ctx , gyGetStakeAddressInfo = nodeStakeAddressInfo (ctxInfo ctx) } -- | Function to find for the first locked output in the given `GYTxBody` at the given `GYAddress`. findOutput :: GYAddress -> GYTxBody -> IO GYTxOutRef findOutput addr txBody = do - let utxos = txBodyUTxOs txBody - maybe (assertFailure "expecting an order in utxos") return $ - findFirst (\utxo -> if utxoAddress utxo == addr then Just (utxoRef utxo) else Nothing) $ utxosToList utxos + let utxos = txBodyUTxOs txBody + maybe (assertFailure "expecting an order in utxos") return $ + findFirst (\utxo -> if utxoAddress utxo == addr then Just (utxoRef utxo) else Nothing) $ + utxosToList utxos diff --git a/src/GeniusYield/Test/Privnet/Examples.hs b/src/GeniusYield/Test/Privnet/Examples.hs index 621fac30..de8451e6 100644 --- a/src/GeniusYield/Test/Privnet/Examples.hs +++ b/src/GeniusYield/Test/Privnet/Examples.hs @@ -1,23 +1,24 @@ -{-| +{- | Module : GeniusYield.Test.Privnet.Examples Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Test.Privnet.Examples (tests) where -import Test.Tasty (TestTree, testGroup) +import Test.Tasty (TestTree, testGroup) -import qualified GeniusYield.Test.Privnet.Examples.Gift -import qualified GeniusYield.Test.Privnet.Examples.Oracle -import qualified GeniusYield.Test.Privnet.Examples.Treat -import qualified GeniusYield.Test.Privnet.Examples.Misc -import GeniusYield.Test.Privnet.Setup +import GeniusYield.Test.Privnet.Examples.Gift qualified +import GeniusYield.Test.Privnet.Examples.Misc qualified +import GeniusYield.Test.Privnet.Examples.Oracle qualified +import GeniusYield.Test.Privnet.Examples.Treat qualified +import GeniusYield.Test.Privnet.Setup tests :: Setup -> TestTree -tests setup = testGroup "examples" +tests setup = + testGroup + "examples" [ GeniusYield.Test.Privnet.Examples.Gift.tests setup , GeniusYield.Test.Privnet.Examples.Treat.tests setup , GeniusYield.Test.Privnet.Examples.Oracle.tests setup diff --git a/src/GeniusYield/Test/Privnet/Examples/Common.hs b/src/GeniusYield/Test/Privnet/Examples/Common.hs index f53b572c..694cb920 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Common.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Common.hs @@ -1,9 +1,9 @@ module GeniusYield.Test.Privnet.Examples.Common (addRefScriptToLimbo) where -import GeniusYield.Examples.Limbo -import GeniusYield.Test.Utils -import GeniusYield.TxBuilder -import GeniusYield.Types +import GeniusYield.Examples.Limbo +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types addRefScriptToLimbo :: GYScript PlutusV2 -> GYTxMonadIO GYTxOutRef addRefScriptToLimbo sc = scriptAddress limboValidatorV2 >>= flip addRefScript sc diff --git a/src/GeniusYield/Test/Privnet/Examples/Gift.hs b/src/GeniusYield/Test/Privnet/Examples/Gift.hs index fc5a35ae..731a589b 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Gift.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Gift.hs @@ -1,44 +1,44 @@ -{-| +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +{- | Module : GeniusYield.Test.Privnet.Examples.Gift Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} - -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} - module GeniusYield.Test.Privnet.Examples.Gift (tests) where -import qualified Cardano.Api as Api -import Cardano.Ledger.Alonzo.PParams (ppCollateralPercentageL) -import Control.Applicative ((<|>)) -import Control.Concurrent (threadDelay) -import Control.Lens ((.~), (^.)) -import Data.Default (Default (def)) -import Data.Maybe (fromJust) -import Data.Ratio ((%)) -import qualified Data.Set as Set -import GeniusYield.Examples.Gift -import GeniusYield.Examples.Treat -import GeniusYield.Imports -import GeniusYield.Providers.Common (SubmitTxException) -import GeniusYield.Test.Privnet.Asserts -import GeniusYield.Test.Privnet.Ctx -import GeniusYield.Test.Privnet.Examples.Common -import GeniusYield.Test.Privnet.Setup -import GeniusYield.TxBuilder -import GeniusYield.Types -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCaseSteps) +import Cardano.Api qualified as Api +import Cardano.Ledger.Alonzo.PParams (ppCollateralPercentageL) +import Control.Applicative ((<|>)) +import Control.Concurrent (threadDelay) +import Control.Lens ((.~), (^.)) +import Data.Default (Default (def)) +import Data.Maybe (fromJust) +import Data.Ratio ((%)) +import Data.Set qualified as Set +import GeniusYield.Examples.Gift +import GeniusYield.Examples.Treat +import GeniusYield.Imports +import GeniusYield.Providers.Common (SubmitTxException) +import GeniusYield.Test.Privnet.Asserts +import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Examples.Common +import GeniusYield.Test.Privnet.Setup +import GeniusYield.TxBuilder +import GeniusYield.Types +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps) pattern InsufficientFundsException :: GYTxMonadException pattern InsufficientFundsException <- GYBuildTxException (GYBuildTxBalancingError (GYBalancingErrorInsufficientFunds _)) tests :: Setup -> TestTree -tests setup = testGroup "gift" +tests setup = + testGroup + "gift" [ testCaseSteps "plutusV1" $ \info -> withSetup info setup $ \ctx -> do giftCleanup ctx let goldAC = ctxGold ctx @@ -47,18 +47,20 @@ tests setup = testGroup "gift" balance2 <- ctxQueryBalance ctx (ctxUser2 ctx) ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV1 - txBodyPlace <- buildTxBody $ mconcat + addr <- scriptAddress giftValidatorV1 + txBodyPlace <- + buildTxBody $ + mconcat [ mustHaveOutput $ mkGYTxOut addr (valueSingleton goldAC 10) (datumFromPlutusData ()) ] - signAndSubmitConfirmed_ txBodyPlace + signAndSubmitConfirmed_ txBodyPlace -- wait a tiny bit. threadDelay 1_000_000 ctxRun ctx (ctxUser2 ctx) $ do - grabGiftsTx' <- grabGifts @'PlutusV1 giftValidatorV1 >>= traverse buildTxBody - mapM_ signAndSubmitConfirmed grabGiftsTx' + grabGiftsTx' <- grabGifts @'PlutusV1 giftValidatorV1 >>= traverse buildTxBody + mapM_ signAndSubmitConfirmed grabGiftsTx' balance1' <- ctxQueryBalance ctx (ctxUserF ctx) balance2' <- ctxQueryBalance ctx (ctxUser2 ctx) @@ -66,14 +68,15 @@ tests setup = testGroup "gift" let diff1 = valueMinus balance1' balance1 let diff2 = valueMinus balance2' balance2 - assertEqual "User1 token balance" - (valueSingleton goldAC (-10)) - (snd (valueSplitAda diff1)) - - assertEqual "User2 token balance" - (valueSingleton goldAC 10) - (snd (valueSplitAda diff2)) + assertEqual + "User1 token balance" + (valueSingleton goldAC (-10)) + (snd (valueSplitAda diff1)) + assertEqual + "User2 token balance" + (valueSingleton goldAC 10) + (snd (valueSplitAda diff2)) , testCaseSteps "plutusV2" $ \info -> withSetup info setup $ \ctx -> do giftCleanup ctx @@ -83,16 +86,16 @@ tests setup = testGroup "gift" balance2 <- ctxQueryBalance ctx (ctxUser2 ctx) ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV2 - txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - signAndSubmitConfirmed_ txBodyPlace + addr <- scriptAddress giftValidatorV2 + txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + signAndSubmitConfirmed_ txBodyPlace -- wait a tiny bit. threadDelay 1_000_000 ctxRun ctx (ctxUser2 ctx) $ do - grabGiftsTx' <- grabGifts @'PlutusV2 giftValidatorV2 >>= traverse buildTxBody - mapM_ signAndSubmitConfirmed grabGiftsTx' + grabGiftsTx' <- grabGifts @'PlutusV2 giftValidatorV2 >>= traverse buildTxBody + mapM_ signAndSubmitConfirmed grabGiftsTx' balance1' <- ctxQueryBalance ctx (ctxUserF ctx) balance2' <- ctxQueryBalance ctx (ctxUser2 ctx) @@ -100,14 +103,15 @@ tests setup = testGroup "gift" let diff1 = valueMinus balance1' balance1 let diff2 = valueMinus balance2' balance2 - assertEqual "User1 token balance" - (valueSingleton ironAC (-10)) - (snd (valueSplitAda diff1)) - - assertEqual "User2 token balance" - (valueSingleton ironAC 10) - (snd (valueSplitAda diff2)) + assertEqual + "User1 token balance" + (valueSingleton ironAC (-10)) + (snd (valueSplitAda diff1)) + assertEqual + "User2 token balance" + (valueSingleton ironAC 10) + (snd (valueSplitAda diff2)) , testCaseSteps "plutusV2-inlinedatum" $ \info -> withSetup info setup $ \ctx -> do giftCleanup ctx let ironAC = ctxIron ctx @@ -116,18 +120,22 @@ tests setup = testGroup "gift" balance2 <- ctxQueryBalance ctx (ctxUser2 ctx) ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV2 - txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - & gyTxOutDatumL .~ GYTxOutUseInlineDatum @'PlutusV2 + addr <- scriptAddress giftValidatorV2 + txBodyPlace <- + buildTxBody $ + mustHaveOutput $ + mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + & gyTxOutDatumL + .~ GYTxOutUseInlineDatum @'PlutusV2 - signAndSubmitConfirmed_ txBodyPlace + signAndSubmitConfirmed_ txBodyPlace -- wait a tiny bit. threadDelay 1_000_000 ctxRun ctx (ctxUser2 ctx) $ do - grabGiftsTx' <- grabGifts @'PlutusV2 giftValidatorV2 >>= traverse buildTxBody - mapM_ signAndSubmitConfirmed grabGiftsTx' + grabGiftsTx' <- grabGifts @'PlutusV2 giftValidatorV2 >>= traverse buildTxBody + mapM_ signAndSubmitConfirmed grabGiftsTx' balance1' <- ctxQueryBalance ctx (ctxUserF ctx) balance2' <- ctxQueryBalance ctx (ctxUser2 ctx) @@ -135,14 +143,15 @@ tests setup = testGroup "gift" let diff1 = valueMinus balance1' balance1 let diff2 = valueMinus balance2' balance2 - assertEqual "User1 token balance" - (valueSingleton ironAC (-10)) - (snd (valueSplitAda diff1)) - - assertEqual "User2 token balance" - (valueSingleton ironAC 10) - (snd (valueSplitAda diff2)) + assertEqual + "User1 token balance" + (valueSingleton ironAC (-10)) + (snd (valueSplitAda diff1)) + assertEqual + "User2 token balance" + (valueSingleton ironAC 10) + (snd (valueSplitAda diff2)) , testCaseSteps "Checking Vasil feature of Collateral Return and Total Collateral - Multi-asset collateral" $ \info -> withSetup info setup $ \ctx -> do giftCleanup ctx @@ -153,8 +162,8 @@ tests setup = testGroup "gift" info $ printf "Newly created user's address %s" (show $ userAddr newUser) ----------- (ctxUserF ctx) submits some gifts txBodyPlace <- ctxRunBuilder ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV2 - buildTxBody $ mustHaveOutput (mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ())) + addr <- scriptAddress giftValidatorV2 + buildTxBody $ mustHaveOutput (mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ())) assertBool "Collateral input shouldn't be set for this transaction" (txBodyCollateral txBodyPlace == mempty) assertBool "Return collateral shouldn't be set for this transaction" (txBodyCollateralReturnOutput txBodyPlace == Api.TxReturnCollateralNone) assertBool "Total collateral shouldn't be set for this transaction" (txBodyTotalCollateralLovelace txBodyPlace == 0) @@ -167,19 +176,19 @@ tests setup = testGroup "gift" forUTxOs_ newUserUtxos (info . show) ---------- New user tries to grab it, since interacting with script, needs to give collateral - grabGiftsTxBody <- ctxRunBuilder ctx newUser $ grabGifts @'PlutusV2 giftValidatorV2 >>= traverse buildTxBody + grabGiftsTxBody <- ctxRunBuilder ctx newUser $ grabGifts @'PlutusV2 giftValidatorV2 >>= traverse buildTxBody grabGiftsTxBody' <- case grabGiftsTxBody of - Nothing -> assertFailure "Unable to build tx" + Nothing -> assertFailure "Unable to build tx" Just body -> return body retCollOutput@(Api.TxReturnCollateral _ (Api.TxOut retCollAddrApi _ _ _)) <- case txBodyCollateralReturnOutput grabGiftsTxBody' of - Api.TxReturnCollateralNone -> fail "Return collateral is not present" - retCollOutput' -> return retCollOutput' + Api.TxReturnCollateralNone -> fail "Return collateral is not present" + retCollOutput' -> return retCollOutput' let totalCollateral = txBodyTotalCollateralLovelace grabGiftsTxBody' retCollValue = txBodyCollateralReturnOutputValue grabGiftsTxBody' retCollAddr = addressFromApi' retCollAddrApi info $ printf "Return collateral: %s" (show retCollOutput) info $ printf "Total collateral: %s" (show totalCollateral) - assertBool "Return collateral value is zero" $ retCollValue /= mempty + assertBool "Return collateral value is zero" $ retCollValue /= mempty assertBool "Total collateral does not exist or value is not positive" $ totalCollateral > 0 assertBool "Return collateral at different address" $ retCollAddr == userAddr newUser pp <- gyGetProtocolParameters $ ctxProviders ctx @@ -187,25 +196,23 @@ tests setup = testGroup "gift" colls' <- ctxRunQuery ctx $ utxosAtTxOutRefs (Set.toList colls) assertBool "Collateral outputs not correctly setup" $ checkCollateral (foldMapUTxOs utxoValue colls') retCollValue (toInteger totalCollateral) (txBodyFee grabGiftsTxBody') (toInteger $ pp ^. ppCollateralPercentageL) ctxRun ctx newUser $ signAndSubmitConfirmed_ grabGiftsTxBody' - , testCaseSteps "Checking if collateral is reserved in case we send an exact 5 ada only UTxO as collateral (simulating browser's case) + is collateral spendable if we want?" $ \info -> withSetup info setup $ \ctx -> do ----------- Create a new user and fund it let ironAC = ctxIron ctx newUserValue = valueFromLovelace 200_000_000 <> valueSingleton ironAC 25 - newUser <- newTempUserCtx ctx (ctxUserF ctx) newUserValue (CreateUserConfig { cucGenerateCollateral = True, cucGenerateStakeKey = False }) + newUser <- newTempUserCtx ctx (ctxUserF ctx) newUserValue (CreateUserConfig {cucGenerateCollateral = True, cucGenerateStakeKey = False}) info $ printf "UTxOs at this new user" newUserUtxos <- ctxRunQuery ctx $ utxosAtAddress (userAddr newUser) Nothing forUTxOs_ newUserUtxos (info . show) fiveAdaUtxo <- case find (\u -> utxoValue u == collateralValue) (utxosToList newUserUtxos) of - Nothing -> fail "Couldn't find a 5-ada-only UTxO" - Just fiveAdaUtxo' -> return fiveAdaUtxo' + Nothing -> fail "Couldn't find a 5-ada-only UTxO" + Just fiveAdaUtxo' -> return fiveAdaUtxo' assertThrown (\case InsufficientFundsException -> True; _anyOther -> False) $ ctxRunBuilderWithCollateral ctx newUser (utxoRef fiveAdaUtxo) False $ buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum (userAddr newUser) (newUserValue `valueMinus` valueFromLovelace 3_000_000) -- Should be reserved if we also perform 5 ada check as it satisfies it. assertThrown (\case InsufficientFundsException -> True; _anyOther -> False) $ ctxRunBuilderWithCollateral ctx newUser (utxoRef fiveAdaUtxo) True $ buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum (userAddr newUser) (newUserValue `valueMinus` valueFromLovelace 3_000_000) -- Would have thrown error if unable to build body. void $ ctxRunBuilder ctx newUser $ buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum (userAddr newUser) (newUserValue `valueMinus` valueFromLovelace 3_000_000) - , testCaseSteps "Checking for 'GYBuildTxNoSuitableCollateral' error when no UTxO is greater than or equal to maximum possible total collateral (assuming no reference scripts)" $ \info -> withSetup info setup $ \ctx -> do ----------- Create a new user and fund it pp <- gyGetProtocolParameters (ctxProviders ctx) @@ -216,7 +223,6 @@ tests setup = testGroup "gift" newUserUtxos <- ctxRunQuery ctx $ utxosAtAddress (userAddr newUser) Nothing forUTxOs_ newUserUtxos (info . show) assertThrown (\case (GYBuildTxException GYBuildTxNoSuitableCollateral) -> True; _anyOther -> False) $ ctxRun ctx newUser $ buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum (userAddr newUser) (valueFromLovelace 1_000_000) - , testCaseSteps "Checking for 'GYBuildTxNoSuitableCollateral' error when UTxO is greater than or equal to maximum possible total collateral (assuming no reference scripts) but resulting return collateral doesn't satisfy minimum ada requirement" $ \info -> withSetup info setup $ \ctx -> do pp <- gyGetProtocolParameters (ctxProviders ctx) ----------- Create a new user and fund it @@ -227,7 +233,6 @@ tests setup = testGroup "gift" newUserUtxos <- ctxRunQuery ctx $ utxosAtAddress (userAddr newUser) Nothing forUTxOs_ newUserUtxos (info . show) assertThrown (\case (GYBuildTxException GYBuildTxNoSuitableCollateral) -> True; _anyOther -> False) $ ctxRun ctx newUser $ buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum (userAddr newUser) (valueFromLovelace 1_000_000) - , testCaseSteps "No 'GYBuildTxNoSuitableCollateral' error is thrown when collateral input is sufficient" $ \info -> withSetup info setup $ \ctx -> do pp <- gyGetProtocolParameters (ctxProviders ctx) ----------- Create a new user and fund it @@ -238,45 +243,45 @@ tests setup = testGroup "gift" newUserUtxos <- ctxRunQuery ctx $ utxosAtAddress (userAddr newUser) Nothing forUTxOs_ newUserUtxos (info . show) void $ ctxRunBuilder ctx newUser $ buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum (userAddr newUser) (valueFromLovelace 1_000_000) - , testCaseSteps "Checking if collateral is reserved in case we want it even if it's value is not 5 ada" $ \info -> withSetup info setup $ \ctx -> do ----------- Create a new user and fund it newUser <- newTempUserCtx ctx (ctxUserF ctx) (valueFromLovelace 40_000_000) def -- Add another UTxO to be used as collateral. ctxRun ctx (ctxUserF ctx) $ do - txBody <- buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum (userAddr newUser) (valueFromLovelace 8_000_000) - signAndSubmitConfirmed_ txBody + txBody <- buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum (userAddr newUser) (valueFromLovelace 8_000_000) + signAndSubmitConfirmed_ txBody info $ printf "UTxOs at this new user" newUserUtxos <- ctxRunQuery ctx $ utxosAtAddress (userAddr newUser) Nothing forUTxOs_ newUserUtxos (info . show) eightAdaUtxo <- case find (\u -> utxoValue u == valueFromLovelace 8_000_000) (utxosToList newUserUtxos) of - Nothing -> fail "Couldn't find a 8-ada-only UTxO" - Just u -> return u + Nothing -> fail "Couldn't find a 8-ada-only UTxO" + Just u -> return u let newUserValue = foldlUTxOs' (\a u -> a <> utxoValue u) mempty newUserUtxos assertThrown (\case InsufficientFundsException -> True; _anyOther -> False) $ ctxRunBuilderWithCollateral ctx newUser (utxoRef eightAdaUtxo) False $ buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum (userAddr newUser) (newUserValue `valueMinus` valueFromLovelace 3_000_000) -- eight ada utxo won't satisfy 5 ada check and thus would be ignored void $ ctxRunBuilderWithCollateral ctx newUser (utxoRef eightAdaUtxo) True $ buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum (userAddr newUser) (newUserValue `valueMinus` valueFromLovelace 3_000_000) - , testCaseSteps "Testing signature from stake key" $ \info -> withSetup info setup $ \ctx -> do ----------- Create a new user and fund it let newUserValue = valueFromLovelace 200_000_000 <> valueSingleton (ctxIron ctx) 25 submitWithoutStakeKey User {..} txBody = do let tx = signGYTxBody' txBody [GYSomeSigningKey userPaymentSKey] void $ submitTxConfirmed tx - newUser <- newTempUserCtx ctx (ctxUserF ctx) newUserValue (CreateUserConfig { cucGenerateCollateral = True, cucGenerateStakeKey = True }) + newUser <- newTempUserCtx ctx (ctxUserF ctx) newUserValue (CreateUserConfig {cucGenerateCollateral = True, cucGenerateStakeKey = True}) info $ printf "UTxOs at this new user" newUserUtxos <- ctxRunQuery ctx $ utxosAtAddress (userAddr newUser) Nothing forUTxOs_ newUserUtxos (info . show) - catch (ctxRun ctx newUser $ do - txBody <- buildTxBody $ mustBeSignedBy (userStakePkh newUser & fromJust) <> mustHaveOutput (mkGYTxOutNoDatum (userAddr newUser) (newUserValue `valueMinus` valueFromLovelace 3_000_000)) - submitWithoutStakeKey newUser txBody) - -- When signed without required stake key, should give a submit exception. - $ \(_ :: SubmitTxException) -> pure () - -- Signing should go smoothly. - - , testCaseSteps "Matching Reference Script from UTxO" $ \info -> withSetup info setup $ \ctx -> do + catch + ( ctxRun ctx newUser $ do + txBody <- buildTxBody $ mustBeSignedBy (userStakePkh newUser & fromJust) <> mustHaveOutput (mkGYTxOutNoDatum (userAddr newUser) (newUserValue `valueMinus` valueFromLovelace 3_000_000)) + submitWithoutStakeKey newUser txBody + ) + -- When signed without required stake key, should give a submit exception. + $ \(_ :: SubmitTxException) -> pure () + , -- Signing should go smoothly. + + testCaseSteps "Matching Reference Script from UTxO" $ \info -> withSetup info setup $ \ctx -> do giftCleanup ctx ref <- ctxRun ctx (ctxUserF ctx) . addRefScriptToLimbo $ validatorToScript giftValidatorV2 @@ -291,7 +296,6 @@ tests setup = testGroup "gift" case mUtxo of Just utxo -> maybe (assertFailure "No Reference Script exists in the added UTxO.") (\s -> if s == GYPlutusScript (validatorToScript giftValidatorV2) then info "Script matched, able to read reference script from UTxO." else assertFailure "Mismatch.") (utxoRefScript utxo) Nothing -> assertFailure "Couldn't find the UTxO containing added Reference Script." - , testCaseSteps "refscript" $ \info -> withSetup info setup $ \ctx -> do giftCleanup ctx let ironAC = ctxIron ctx @@ -310,10 +314,10 @@ tests setup = testGroup "gift" -- put some gifts ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV2 - txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + addr <- scriptAddress giftValidatorV2 + txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - signAndSubmitConfirmed_ txBodyPlace + signAndSubmitConfirmed_ txBodyPlace -- wait a tiny bit. threadDelay 1_000_000 @@ -321,8 +325,8 @@ tests setup = testGroup "gift" -- NOTE: TxValidationErrorInMode (ShelleyTxValidationError ShelleyBasedEraBabbage (ApplyTxError [UtxowFailure (FromAlonzoUtxowFail (WrappedShelleyEraFailure (ExtraneousScriptWitnessesUTXOW -- Apparently we MUST NOT include the script if there is a utxo input with that script. Even if we consume that utxo. ctxRun ctx (ctxUser2 ctx) $ do - grabGiftsTx' <- grabGiftsRef ref giftValidatorV2 >>= traverse buildTxBody - mapM_ signAndSubmitConfirmed grabGiftsTx' + grabGiftsTx' <- grabGiftsRef ref giftValidatorV2 >>= traverse buildTxBody + mapM_ signAndSubmitConfirmed grabGiftsTx' -- Check final balance balance1' <- ctxQueryBalance ctx (ctxUserF ctx) @@ -331,14 +335,15 @@ tests setup = testGroup "gift" let diff1 = valueMinus balance1' balance1 let diff2 = valueMinus balance2' balance2 - assertEqual "User1 token balance" - (valueSingleton ironAC (-10)) - (snd (valueSplitAda diff1)) - - assertEqual "User2 token balance" - (valueSingleton ironAC 10) - (snd (valueSplitAda diff2)) + assertEqual + "User1 token balance" + (valueSingleton ironAC (-10)) + (snd (valueSplitAda diff1)) + assertEqual + "User2 token balance" + (valueSingleton ironAC 10) + (snd (valueSplitAda diff2)) , testCaseSteps "refinputs" $ \info -> withSetup info setup $ \ctx -> do -- this is a bad test, but for proper one we'll need a script -- actually using reference input provided. @@ -359,10 +364,10 @@ tests setup = testGroup "gift" -- put some gifts ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV2 - txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + addr <- scriptAddress giftValidatorV2 + txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - signAndSubmitConfirmed_ txBodyPlace + signAndSubmitConfirmed_ txBodyPlace -- wait a tiny bit. threadDelay 1_000_000 @@ -370,11 +375,11 @@ tests setup = testGroup "gift" -- NOTE: TxValidationErrorInMode (ShelleyTxValidationError ShelleyBasedEraBabbage (ApplyTxError [UtxowFailure (FromAlonzoUtxowFail (WrappedShelleyEraFailure (ExtraneousScriptWitnessesUTXOW -- Apparently we MUST NOT include the script if there is a utxo input with that script. Even if we consume that utxo. ctxRun ctx (ctxUser2 ctx) $ do - -- We spend the gifts and give the transaction (unused) reference input - -- we need to use 'PlutusV2 here. - s1 <- grabGifts @'PlutusV2 giftValidatorV2 - grabGiftsTx' <- traverse buildTxBody $ s1 <|> Just (mustHaveRefInput ref) - mapM_ signAndSubmitConfirmed grabGiftsTx' + -- We spend the gifts and give the transaction (unused) reference input + -- we need to use 'PlutusV2 here. + s1 <- grabGifts @'PlutusV2 giftValidatorV2 + grabGiftsTx' <- traverse buildTxBody $ s1 <|> Just (mustHaveRefInput ref) + mapM_ signAndSubmitConfirmed grabGiftsTx' -- Check final balance balance1' <- ctxQueryBalance ctx (ctxUserF ctx) @@ -383,14 +388,15 @@ tests setup = testGroup "gift" let diff1 = valueMinus balance1' balance1 let diff2 = valueMinus balance2' balance2 - assertEqual "User1 token balance" - (valueSingleton ironAC (-10)) - (snd (valueSplitAda diff1)) - - assertEqual "User2 token balance" - (valueSingleton ironAC 10) - (snd (valueSplitAda diff2)) + assertEqual + "User1 token balance" + (valueSingleton ironAC (-10)) + (snd (valueSplitAda diff1)) + assertEqual + "User2 token balance" + (valueSingleton ironAC 10) + (snd (valueSplitAda diff2)) , testCaseSteps "refscript_mixup" $ \info -> withSetup info setup $ \ctx -> do -- in this test we consume 'PlutusV1 UTxO and 'PlutusV2 UTxO -- that should be fine, but we are using reference scripts for consuming 'PlutusV2 @@ -409,31 +415,30 @@ tests setup = testGroup "gift" -- put some V2 gifts ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV2 - txBodyPlaceV2 <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + addr <- scriptAddress giftValidatorV2 + txBodyPlaceV2 <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - signAndSubmitConfirmed_ txBodyPlaceV2 + signAndSubmitConfirmed_ txBodyPlaceV2 info "Put V2 gifts" -- put some V1 gifts ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV1 - txBodyPlaceV1 <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + addr <- scriptAddress giftValidatorV1 + txBodyPlaceV1 <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - signAndSubmitConfirmed_ txBodyPlaceV1 + signAndSubmitConfirmed_ txBodyPlaceV1 info "Put V1 gifts" - - -- Try to consume V1 and V2 gifts in the same transaction - {- Doesn't compile. - assertThrown isTxBodyErrorAutoBalance $ ctxRunF ctx (ctxUser2 ctx) $ do - sV2 <- grabGiftsRef ref giftValidatorV2 - sV1 <- grabGifts giftValidatorV1 - return (liftA2 (<>) sV2 sV1) - -} - - , testCaseSteps "inline datums V1+V2" $ \info -> withSetup info setup $ \ctx -> do + , -- Try to consume V1 and V2 gifts in the same transaction + {- Doesn't compile. + assertThrown isTxBodyErrorAutoBalance $ ctxRunF ctx (ctxUser2 ctx) $ do + sV2 <- grabGiftsRef ref giftValidatorV2 + sV1 <- grabGifts giftValidatorV1 + return (liftA2 (<>) sV2 sV1) + -} + + testCaseSteps "inline datums V1+V2" $ \info -> withSetup info setup $ \ctx -> do -- in this test we consume UTxO with Plutus V1 script -- and in the same transaction create an output where we force inline datum usage -- @@ -442,10 +447,10 @@ tests setup = testGroup "gift" -- place a gift, plutus version V1 ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV1 - txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + addr <- scriptAddress giftValidatorV1 + txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - signAndSubmitConfirmed_ txBodyPlace + signAndSubmitConfirmed_ txBodyPlace -- wait a tiny bit. threadDelay 1_000_000 @@ -469,7 +474,6 @@ tests setup = testGroup "gift" -- wait a tiny bit. threadDelay 1_000_000 - , testCaseSteps "inline datums V2" $ \info -> withSetup info setup $ \ctx -> do -- in this test, there are only V2 scripts -- so everything seems to work. @@ -482,9 +486,9 @@ tests setup = testGroup "gift" -- place a gift, plutus version V1 ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV2 - txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - signAndSubmitConfirmed_ txBodyPlace + addr <- scriptAddress giftValidatorV2 + txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + signAndSubmitConfirmed_ txBodyPlace -- wait a tiny bit. threadDelay 1_000_000 @@ -492,20 +496,22 @@ tests setup = testGroup "gift" -- TODO: NonOutputSupplimentaryDatums is thrown by other tests when this test is run. -- They fail to consume utxos with (inline) datums. -- We need to fix utxosDatums to also return whether the datum was inline. - let addNewGiftV2 :: GYTxUserQueryMonad m => GYTxSkeleton 'PlutusV2 -> m (GYTxSkeleton 'PlutusV2) + let addNewGiftV2 :: (GYTxUserQueryMonad m) => GYTxSkeleton 'PlutusV2 -> m (GYTxSkeleton 'PlutusV2) addNewGiftV2 skeleton = do - addr <- scriptAddress giftValidatorV2 - return $ skeleton <> mustHaveOutput GYTxOut - { gyTxOutAddress = addr - , gyTxOutValue = valueSingleton ironAC 10 - , gyTxOutDatum = Just (datumFromPlutusData (), GYTxOutUseInlineDatum) - , gyTxOutRefS = Nothing - } + addr <- scriptAddress giftValidatorV2 + return $ + skeleton + <> mustHaveOutput + GYTxOut + { gyTxOutAddress = addr + , gyTxOutValue = valueSingleton ironAC 10 + , gyTxOutDatum = Just (datumFromPlutusData (), GYTxOutUseInlineDatum) + , gyTxOutRefS = Nothing + } ctxRun ctx (ctxUser2 ctx) $ do - grabGiftsTx' <- grabGifts giftValidatorV2 >>= traverse addNewGiftV2 >>= traverse buildTxBody - mapM_ signAndSubmitConfirmed grabGiftsTx' - + grabGiftsTx' <- grabGifts giftValidatorV2 >>= traverse addNewGiftV2 >>= traverse buildTxBody + mapM_ signAndSubmitConfirmed grabGiftsTx' , testCaseSteps "inlinedatum-v1v2" $ \info -> withSetup info setup $ \ctx -> do -- in this test we try to consume v1 and v2 script outputs in the same transaction. -- The v2 outputs have inline datums @@ -514,26 +520,28 @@ tests setup = testGroup "gift" let ironAC = ctxIron ctx ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress giftValidatorV1 - txBodyPlace1 <- buildTxBody . mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - signAndSubmitConfirmed_ txBodyPlace1 + addr <- scriptAddress giftValidatorV1 + txBodyPlace1 <- buildTxBody . mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + signAndSubmitConfirmed_ txBodyPlace1 ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress treatValidatorV2 - txBodyPlace2 <- buildTxBody . mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - & gyTxOutDatumL .~ GYTxOutUseInlineDatum @'PlutusV2 + addr <- scriptAddress treatValidatorV2 + txBodyPlace2 <- + buildTxBody . mustHaveOutput $ + mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + & gyTxOutDatumL + .~ GYTxOutUseInlineDatum @'PlutusV2 - signAndSubmitConfirmed_ txBodyPlace2 + signAndSubmitConfirmed_ txBodyPlace2 -- wait a tiny bit. threadDelay 1_000_000 ctxRun ctx (ctxUser2 ctx) $ do - s1 <- grabGifts @'PlutusV1 giftValidatorV1 + s1 <- grabGifts @'PlutusV1 giftValidatorV1 s2 <- grabGifts treatValidatorV2 grabGiftsTx <- traverse buildTxBody $ s1 <|> s2 mapM_ signAndSubmitConfirmed grabGiftsTx - , testCaseSteps "inlinedatum-in-v1" $ \info -> withSetup info setup $ \_ctx -> do -- in this test we try to consume v1 script output which has inline datums -- this doesn't work, and break things. @@ -563,83 +571,101 @@ tests setup = testGroup "gift" giftCleanup :: Ctx -> IO () giftCleanup ctx = do - threadDelay 1_000_000 - - -- grab existing v2 gifts - ctxRun ctx (ctxUserF ctx) $ do - skeletonM <- grabGifts @'PlutusV2 giftValidatorV2 >>= traverse buildTxBody - mapM_ signAndSubmitConfirmed skeletonM - - -- grab existing v1 gifts - ctxRun ctx (ctxUserF ctx) $ do - skeletonM <- grabGifts @'PlutusV1 giftValidatorV1 >>= traverse buildTxBody - mapM_ signAndSubmitConfirmed skeletonM - - -- grab existing treats - ctxRun ctx (ctxUserF ctx) $ do - skeletonM <- grabGifts @'PlutusV2 treatValidatorV2 >>= traverse buildTxBody - mapM_ signAndSubmitConfirmed skeletonM - - threadDelay 1_000_000 - -grabGifts - :: forall u v m. (GYTxQueryMonad m, VersionIsGreaterOrEqual v u) - => GYValidator v - -> m (Maybe (GYTxSkeleton u)) + threadDelay 1_000_000 + + -- grab existing v2 gifts + ctxRun ctx (ctxUserF ctx) $ do + skeletonM <- grabGifts @'PlutusV2 giftValidatorV2 >>= traverse buildTxBody + mapM_ signAndSubmitConfirmed skeletonM + + -- grab existing v1 gifts + ctxRun ctx (ctxUserF ctx) $ do + skeletonM <- grabGifts @'PlutusV1 giftValidatorV1 >>= traverse buildTxBody + mapM_ signAndSubmitConfirmed skeletonM + + -- grab existing treats + ctxRun ctx (ctxUserF ctx) $ do + skeletonM <- grabGifts @'PlutusV2 treatValidatorV2 >>= traverse buildTxBody + mapM_ signAndSubmitConfirmed skeletonM + + threadDelay 1_000_000 + +grabGifts :: + forall u v m. + (GYTxQueryMonad m, VersionIsGreaterOrEqual v u) => + GYValidator v -> + m (Maybe (GYTxSkeleton u)) grabGifts validator = do - addr <- scriptAddress validator - utxo <- utxosAtAddress addr Nothing - datums <- utxosDatums utxo + addr <- scriptAddress validator + utxo <- utxosAtAddress addr Nothing + datums <- utxosDatums utxo - if null datums + if null datums then return Nothing - else return $ Just $ mconcat - [ mustHaveInput GYTxIn - { gyTxInTxOutRef = oref - , gyTxInWitness = GYTxInWitnessScript - (GYInScript validator) - (datumFromPlutus' od) - unitRedeemer - } - | (oref, (_addr, _value, od)) <- itoList datums - ] + else + return $ + Just $ + mconcat + [ mustHaveInput + GYTxIn + { gyTxInTxOutRef = oref + , gyTxInWitness = + GYTxInWitnessScript + (GYInScript validator) + (datumFromPlutus' od) + unitRedeemer + } + | (oref, (_addr, _value, od)) <- itoList datums + ] -- | Grab gifts using a referenced validator. -grabGiftsRef - :: GYTxQueryMonad m - => GYTxOutRef - -> GYValidator 'PlutusV2 - -> m (Maybe (GYTxSkeleton 'PlutusV2)) +grabGiftsRef :: + (GYTxQueryMonad m) => + GYTxOutRef -> + GYValidator 'PlutusV2 -> + m (Maybe (GYTxSkeleton 'PlutusV2)) grabGiftsRef ref validator = do - addr <- scriptAddress validator - utxo <- utxosAtAddress addr Nothing - datums <- utxosDatums utxo + addr <- scriptAddress validator + utxo <- utxosAtAddress addr Nothing + datums <- utxosDatums utxo - if null datums + if null datums then return Nothing - else return $ Just $ mconcat - [ mustHaveInput GYTxIn - { gyTxInTxOutRef = oref - , gyTxInWitness = GYTxInWitnessScript - (GYInReference ref $ validatorToScript validator) - (datumFromPlutus' od) - unitRedeemer - } - | (oref, (_addr, _value, od)) <- itoList datums - ] + else + return $ + Just $ + mconcat + [ mustHaveInput + GYTxIn + { gyTxInTxOutRef = oref + , gyTxInWitness = + GYTxInWitnessScript + (GYInReference ref $ validatorToScript validator) + (datumFromPlutus' od) + unitRedeemer + } + | (oref, (_addr, _value, od)) <- itoList datums + ] -- | Function to check for consistency of collaterals with respect to ledger laws. -checkCollateral :: Integral a - => GYValue -- ^ Sum of values present in collateral inputs. - -> GYValue -- ^ Value present in return collateral output. - -> Integer -- ^ Total collateral lovelaces. - -> a -- ^ Transaction fees. - -> a -- ^ Collateral percent (Protocol parameter). - -> Bool +checkCollateral :: + (Integral a) => + -- | Sum of values present in collateral inputs. + GYValue -> + -- | Value present in return collateral output. + GYValue -> + -- | Total collateral lovelaces. + Integer -> + -- | Transaction fees. + a -> + -- | Collateral percent (Protocol parameter). + a -> + Bool checkCollateral inputValue returnValue totalCollateralLovelace txFee collPer = - isEmptyValue balanceOther - && balanceLovelace >= 0 - && totalCollateralLovelace == balanceLovelace - && balanceLovelace>= ceiling (txFee * collPer % 100) -- Api checks via `balanceLovelace * 100 >= txFee * collPer` which IMO works as `balanceLovelace` is an integer & 100 but in general `c >= ceil (a / b)` is not equivalent to `c * b >= a`. - && inputValue == returnValue <> valueFromLovelace totalCollateralLovelace - where (balanceLovelace, balanceOther) = valueSplitAda $ inputValue `valueMinus` returnValue + isEmptyValue balanceOther + && balanceLovelace >= 0 + && totalCollateralLovelace == balanceLovelace + && balanceLovelace >= ceiling (txFee * collPer % 100) -- Api checks via `balanceLovelace * 100 >= txFee * collPer` which IMO works as `balanceLovelace` is an integer & 100 but in general `c >= ceil (a / b)` is not equivalent to `c * b >= a`. + && inputValue == returnValue <> valueFromLovelace totalCollateralLovelace + where + (balanceLovelace, balanceOther) = valueSplitAda $ inputValue `valueMinus` returnValue diff --git a/src/GeniusYield/Test/Privnet/Examples/Misc.hs b/src/GeniusYield/Test/Privnet/Examples/Misc.hs index 38ce8ae9..533f6597 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Misc.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Misc.hs @@ -1,34 +1,33 @@ -{-| +{- | Module : GeniusYield.Test.Privnet.Examples.Misc Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} - module GeniusYield.Test.Privnet.Examples.Misc (tests) where -import Control.Concurrent (threadDelay) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCaseSteps) +import Control.Concurrent (threadDelay) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps) -import GeniusYield.Scripts.TestToken -import GeniusYield.Types +import GeniusYield.Scripts.TestToken +import GeniusYield.Types -import GeniusYield.Test.Privnet.Asserts -import GeniusYield.Test.Privnet.Ctx -import GeniusYield.Test.Privnet.Examples.Common -import GeniusYield.Test.Privnet.Setup -import GeniusYield.TxBuilder +import GeniusYield.Test.Privnet.Asserts +import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Examples.Common +import GeniusYield.Test.Privnet.Setup +import GeniusYield.TxBuilder tests :: Setup -> TestTree -tests setup = testGroup "misc" +tests setup = + testGroup + "misc" [ testCaseSteps "Reference script for minting policy" $ \info -> withSetup info setup $ \ctx -> do - utxoAsParam <- ctxRun ctx (ctxUser2 ctx) $ someUTxO PlutusV1 - let amt = 1 - tn = "mintByRef" + let amt = 1 + tn = "mintByRef" policy = testTokenPolicy amt tn utxoAsParam policyAsScript = mintingPolicyToScript policy ac = GYToken (mintingPolicyId policy) tn @@ -40,10 +39,11 @@ tests setup = testGroup "misc" balance <- ctxQueryBalance ctx (ctxUser2 ctx) ctxRun ctx (ctxUser2 ctx) $ do - txBodyMint <- buildTxBody $ - mustHaveInput (GYTxIn utxoAsParam GYTxInWitnessKey) - <> mustMint (GYMintReference refScript policyAsScript) unitRedeemer tn amt - signAndSubmitConfirmed_ txBodyMint + txBodyMint <- + buildTxBody $ + mustHaveInput (GYTxIn utxoAsParam GYTxInWitnessKey) + <> mustMint (GYMintReference refScript policyAsScript) unitRedeemer tn amt + signAndSubmitConfirmed_ txBodyMint -- wait a tiny bit. threadDelay 1_000_000 diff --git a/src/GeniusYield/Test/Privnet/Examples/Oracle.hs b/src/GeniusYield/Test/Privnet/Examples/Oracle.hs index ff5b606f..fbefa115 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Oracle.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Oracle.hs @@ -1,103 +1,120 @@ -{-| +{- | Module : GeniusYield.Test.Privnet.Examples.Oracle Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Test.Privnet.Examples.Oracle (tests) where -import Control.Lens ((.~)) -import qualified Data.Map.Strict as Map -import Test.Tasty (TestTree, - testGroup) -import Test.Tasty.HUnit (testCaseSteps) +import Control.Lens ((.~)) +import Data.Map.Strict qualified as Map +import Test.Tasty ( + TestTree, + testGroup, + ) +import Test.Tasty.HUnit (testCaseSteps) -import GeniusYield.Examples.Gift -import GeniusYield.Imports -import GeniusYield.OnChain.Examples.ReadOracle.Compiled -import GeniusYield.Test.Privnet.Asserts -import GeniusYield.Test.Privnet.Ctx -import GeniusYield.Test.Privnet.Setup -import GeniusYield.TxBuilder -import GeniusYield.Types +import GeniusYield.Examples.Gift +import GeniusYield.Imports +import GeniusYield.OnChain.Examples.ReadOracle.Compiled +import GeniusYield.Test.Privnet.Asserts +import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Setup +import GeniusYield.TxBuilder +import GeniusYield.Types readOracleValidatorV2 :: GYValidator 'PlutusV2 readOracleValidatorV2 = validatorFromPlutus readOracleValidator tests :: Setup -> TestTree -tests setup = testGroup "oracle" +tests setup = + testGroup + "oracle" [ testCaseSteps "without-ref" $ \info -> withSetup info setup $ \ctx -> do let goldAC = ctxGold ctx -- create output with read oracle script ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress readOracleValidatorV2 - txBodyPlaceOracle <- buildTxBody $ mconcat + addr <- scriptAddress readOracleValidatorV2 + txBodyPlaceOracle <- + buildTxBody $ + mconcat [ mustHaveOutput $ mkGYTxOut addr (valueSingleton goldAC 10) (datumFromPlutusData ()) ] - signAndSubmitConfirmed_ txBodyPlaceOracle + signAndSubmitConfirmed_ txBodyPlaceOracle -- fails: no reference input with datum assertThrown isTxBodyErrorAutoBalance $ ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress readOracleValidatorV2 - utxo <- utxosAtAddress addr Nothing - datums <- utxosDatums utxo - buildTxBody $ mconcat - [ mustHaveInput GYTxIn + addr <- scriptAddress readOracleValidatorV2 + utxo <- utxosAtAddress addr Nothing + datums <- utxosDatums utxo + buildTxBody $ + mconcat + [ mustHaveInput + GYTxIn { gyTxInTxOutRef = ref - , gyTxInWitness = GYTxInWitnessScript - (GYInScript @PlutusV2 readOracleValidatorV2) - (datumFromPlutusData (d :: ())) - unitRedeemer + , gyTxInWitness = + GYTxInWitnessScript + (GYInScript @PlutusV2 readOracleValidatorV2) + (datumFromPlutusData (d :: ())) + unitRedeemer } - | (ref, (_, _, d)) <- Map.toList datums - ] - + | (ref, (_, _, d)) <- Map.toList datums + ] , testCaseSteps "with-ref" $ \info -> withSetup info setup $ \ctx -> do let goldAC = ctxGold ctx -- address - giftValidatorV2Addr <- ctxRunQuery ctx $ + giftValidatorV2Addr <- + ctxRunQuery ctx $ scriptAddress giftValidatorV2 -- create output with input txBodyPlaceDatum <- ctxRun ctx (ctxUserF ctx) $ do - txBodyPlaceDatum <- buildTxBody $ mconcat - [ mustHaveOutput $ mkGYTxOut giftValidatorV2Addr (valueSingleton goldAC 10) (datumFromPlutusData ()) - & gyTxOutDatumL .~ GYTxOutUseInlineDatum @'PlutusV2 + txBodyPlaceDatum <- + buildTxBody $ + mconcat + [ mustHaveOutput $ + mkGYTxOut giftValidatorV2Addr (valueSingleton goldAC 10) (datumFromPlutusData ()) + & gyTxOutDatumL + .~ GYTxOutUseInlineDatum @'PlutusV2 ] - signAndSubmitConfirmed_ txBodyPlaceDatum - pure txBodyPlaceDatum + signAndSubmitConfirmed_ txBodyPlaceDatum + pure txBodyPlaceDatum -- get datum ref. datumRef <- findOutput giftValidatorV2Addr txBodyPlaceDatum -- create output with read oracle script ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress readOracleValidatorV2 - txBodyPlaceOracle <- buildTxBody $ mconcat + addr <- scriptAddress readOracleValidatorV2 + txBodyPlaceOracle <- + buildTxBody $ + mconcat [ mustHaveOutput $ mkGYTxOut addr (valueSingleton goldAC 10) (datumFromPlutusData ()) ] - signAndSubmitConfirmed_ txBodyPlaceOracle + signAndSubmitConfirmed_ txBodyPlaceOracle ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress readOracleValidatorV2 - utxo <- utxosAtAddress addr Nothing - datums <- utxosDatums utxo - txBodyConsume <- buildTxBody . mconcat $ - [ mustHaveInput GYTxIn + addr <- scriptAddress readOracleValidatorV2 + utxo <- utxosAtAddress addr Nothing + datums <- utxosDatums utxo + txBodyConsume <- + buildTxBody . mconcat $ + [ mustHaveInput + GYTxIn { gyTxInTxOutRef = ref - , gyTxInWitness = GYTxInWitnessScript - (GYInScript @PlutusV2 readOracleValidatorV2) - (datumFromPlutusData (d :: ())) - unitRedeemer + , gyTxInWitness = + GYTxInWitnessScript + (GYInScript @PlutusV2 readOracleValidatorV2) + (datumFromPlutusData (d :: ())) + unitRedeemer } - | (ref, (_, _, d)) <- Map.toList datums - ] ++ - [ mustHaveRefInput datumRef - ] + | (ref, (_, _, d)) <- Map.toList datums + ] + ++ [ mustHaveRefInput datumRef + ] - signAndSubmitConfirmed_ txBodyConsume + signAndSubmitConfirmed_ txBodyConsume ] diff --git a/src/GeniusYield/Test/Privnet/Examples/Treat.hs b/src/GeniusYield/Test/Privnet/Examples/Treat.hs index 78b31a71..27af0971 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Treat.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Treat.hs @@ -1,52 +1,54 @@ -{-| +{- | Module : GeniusYield.Test.Privnet.Examples.Treat Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Test.Privnet.Examples.Treat (tests) where -import Control.Concurrent (threadDelay) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCaseSteps) +import Control.Concurrent (threadDelay) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps) -import GeniusYield.Imports -import GeniusYield.Types +import GeniusYield.Imports +import GeniusYield.Types -import GeniusYield.Examples.Treat -import GeniusYield.Test.Privnet.Asserts -import GeniusYield.Test.Privnet.Ctx -import GeniusYield.Test.Privnet.Setup -import GeniusYield.TxBuilder +import GeniusYield.Examples.Treat +import GeniusYield.Test.Privnet.Asserts +import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Setup +import GeniusYield.TxBuilder tests :: Setup -> TestTree -tests setup = testGroup "treat" +tests setup = + testGroup + "treat" [ testCaseSteps "plutusV1" $ \info -> withSetup info setup $ \ctx -> do let goldAC = ctxGold ctx ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress treatValidatorV1 - txBodyPlace <- buildTxBody $ mconcat + addr <- scriptAddress treatValidatorV1 + txBodyPlace <- + buildTxBody $ + mconcat [ mustHaveOutput $ mkGYTxOut addr (valueSingleton goldAC 10) (datumFromPlutusData ()) ] - signAndSubmitConfirmed_ txBodyPlace + signAndSubmitConfirmed_ txBodyPlace threadDelay 1_000_000 -- this fails as we tell that script is 'PlutusV1, -- but it uses V2 features. - assertThrown isTxBodyErrorAutoBalance $ ctxRun ctx (ctxUser2 ctx) $ grabTreats @'PlutusV1 treatValidatorV1 >>= traverse buildTxBody - - -- this is the same tests as for Gift 'PlutusV2. - , testCaseSteps "plutusV2" $ \info -> withSetup info setup $ \ctx -> do + assertThrown isTxBodyErrorAutoBalance $ ctxRun ctx (ctxUser2 ctx) $ grabTreats @'PlutusV1 treatValidatorV1 >>= traverse buildTxBody + , -- this is the same tests as for Gift 'PlutusV2. + testCaseSteps "plutusV2" $ \info -> withSetup info setup $ \ctx -> do let ironAC = ctxIron ctx -- grab existing treats to cleanup ctxRun ctx (ctxUserF ctx) $ do - grabTreatsTx <- grabTreats @'PlutusV2 treatValidatorV2 >>= traverse buildTxBody - mapM_ signAndSubmitConfirmed grabTreatsTx + grabTreatsTx <- grabTreats @'PlutusV2 treatValidatorV2 >>= traverse buildTxBody + mapM_ signAndSubmitConfirmed grabTreatsTx threadDelay 1_000_000 @@ -54,16 +56,16 @@ tests setup = testGroup "treat" balance2 <- ctxQueryBalance ctx (ctxUser2 ctx) ctxRun ctx (ctxUserF ctx) $ do - addr <- scriptAddress treatValidatorV2 - txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - signAndSubmitConfirmed_ txBodyPlace + addr <- scriptAddress treatValidatorV2 + txBodyPlace <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + signAndSubmitConfirmed_ txBodyPlace -- wait a tiny bit. threadDelay 1_000_000 ctxRun ctx (ctxUser2 ctx) $ do - grabTreatsTx' <- grabTreats @'PlutusV2 treatValidatorV2 >>= traverse buildTxBody - mapM_ signAndSubmitConfirmed grabTreatsTx' + grabTreatsTx' <- grabTreats @'PlutusV2 treatValidatorV2 >>= traverse buildTxBody + mapM_ signAndSubmitConfirmed grabTreatsTx' -- wait a tiny bit. threadDelay 1_000_000 @@ -74,33 +76,41 @@ tests setup = testGroup "treat" let diff1 = valueMinus balance1' balance1 let diff2 = valueMinus balance2' balance2 - assertEqual "User1 token balance" - (valueSingleton ironAC (-10)) - (snd (valueSplitAda diff1)) + assertEqual + "User1 token balance" + (valueSingleton ironAC (-10)) + (snd (valueSplitAda diff1)) - assertEqual "User2 token balance" - (valueSingleton ironAC 10) - (snd (valueSplitAda diff2)) + assertEqual + "User2 token balance" + (valueSingleton ironAC 10) + (snd (valueSplitAda diff2)) ] -grabTreats - :: forall u v m. (GYTxUserQueryMonad m, VersionIsGreaterOrEqual v u) - => GYValidator v - -> m (Maybe (GYTxSkeleton u)) +grabTreats :: + forall u v m. + (GYTxUserQueryMonad m, VersionIsGreaterOrEqual v u) => + GYValidator v -> + m (Maybe (GYTxSkeleton u)) grabTreats validator = do - addr <- scriptAddress validator - utxo <- utxosAtAddress addr Nothing - datums <- utxosDatums utxo + addr <- scriptAddress validator + utxo <- utxosAtAddress addr Nothing + datums <- utxosDatums utxo - if null datums + if null datums then return Nothing - else return $ Just $ mconcat - [ mustHaveInput GYTxIn - { gyTxInTxOutRef = oref - , gyTxInWitness = GYTxInWitnessScript - (GYInScript validator) - (datumFromPlutus' od) - unitRedeemer - } - | (oref, (_addr, _value, od)) <- itoList datums - ] + else + return $ + Just $ + mconcat + [ mustHaveInput + GYTxIn + { gyTxInTxOutRef = oref + , gyTxInWitness = + GYTxInWitnessScript + (GYInScript validator) + (datumFromPlutus' od) + unitRedeemer + } + | (oref, (_addr, _value, od)) <- itoList datums + ] diff --git a/src/GeniusYield/Test/Privnet/Setup.hs b/src/GeniusYield/Test/Privnet/Setup.hs index 8a580a0b..ac5cc8e9 100644 --- a/src/GeniusYield/Test/Privnet/Setup.hs +++ b/src/GeniusYield/Test/Privnet/Setup.hs @@ -1,82 +1,87 @@ -{-| +{- | Module : GeniusYield.Test.Privnet.Setup Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Test.Privnet.Setup ( - Setup, - withPrivnet, - withSetup, - withSetup', - withSetupOld, - mkPrivnetTestFor, - mkPrivnetTestFor', - -- * "Cardano.Testnet" re-exports - cardanoDefaultTestnetOptions, - cardanoDefaultTestnetOptionsConway, - cardanoDefaultTestnetNodeOptions, - CardanoTestnetOptions (..), - TestnetNodeOptions (..), - NodeLoggingFormat (..), - NodeConfigurationYaml (..) + Setup, + withPrivnet, + withSetup, + withSetup', + withSetupOld, + mkPrivnetTestFor, + mkPrivnetTestFor', + + -- * "Cardano.Testnet" re-exports + cardanoDefaultTestnetOptions, + cardanoDefaultTestnetOptionsConway, + cardanoDefaultTestnetNodeOptions, + CardanoTestnetOptions (..), + TestnetNodeOptions (..), + NodeLoggingFormat (..), + NodeConfigurationYaml (..), ) where -import qualified Cardano.Api as Api -import Cardano.Api.Ledger -import qualified Cardano.Ledger.Plutus as Ledger -import Cardano.Testnet -import Control.Concurrent (ThreadId, killThread, - threadDelay) -import qualified Control.Concurrent.STM as STM -import Control.Exception (finally) -import Control.Monad (forever) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource (MonadResource (liftResourceT), - resourceForkIO) -import qualified Data.Default.Class as DefaultClass -import qualified Data.Text as Txt -import qualified Data.Vector as V -import qualified GeniusYield.Api.TestTokens as GY.TestTokens -import GeniusYield.Imports -import GeniusYield.Providers.LiteChainIndex -import GeniusYield.Providers.Node -import GeniusYield.Providers.Node.AwaitTx (nodeAwaitTxConfirmed) -import GeniusYield.Providers.Node.Query (nodeQueryUTxO) -import GeniusYield.Test.Privnet.Ctx -import GeniusYield.Test.Privnet.Utils -import GeniusYield.Test.Utils -import GeniusYield.TxBuilder -import GeniusYield.Types -import qualified Hedgehog as H -import qualified Hedgehog.Extras.Stock as H' -import Test.Cardano.Ledger.Core.Rational ((%!)) -import Test.Tasty (TestName, TestTree) -import Test.Tasty.HUnit (testCaseSteps) -import Testnet.Property.Util -import Testnet.Types - +import Cardano.Api qualified as Api +import Cardano.Api.Ledger +import Cardano.Ledger.Plutus qualified as Ledger +import Cardano.Testnet +import Control.Concurrent ( + ThreadId, + killThread, + threadDelay, + ) +import Control.Concurrent.STM qualified as STM +import Control.Exception (finally) +import Control.Monad (forever) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource ( + MonadResource (liftResourceT), + resourceForkIO, + ) +import Data.Default.Class qualified as DefaultClass +import Data.Text qualified as Txt +import Data.Vector qualified as V +import GeniusYield.Api.TestTokens qualified as GY.TestTokens +import GeniusYield.Imports +import GeniusYield.Providers.LiteChainIndex +import GeniusYield.Providers.Node +import GeniusYield.Providers.Node.AwaitTx (nodeAwaitTxConfirmed) +import GeniusYield.Providers.Node.Query (nodeQueryUTxO) +import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Utils +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types +import Hedgehog qualified as H +import Hedgehog.Extras.Stock qualified as H' +import Test.Cardano.Ledger.Core.Rational ((%!)) +import Test.Tasty (TestName, TestTree) +import Test.Tasty.HUnit (testCaseSteps) +import Testnet.Property.Util +import Testnet.Types ------------------------------------------------------------------------------- -- Setup ------------------------------------------------------------------------------- --- | This setup represents a three argument function where first two arguments are for logging & third is for the continuation, in need of `Ctx`. --- --- Once these arguments are given to this function, it will give `Ctx` to the continuation, where the logging part (the `ctxLog`) of `Ctx` would be obtained from the first two arguments of this function. --- --- The first argument is the log severity filter. Only logs of this severity or higher will be passed on to the second argument, which is a logging action. +{- | This setup represents a three argument function where first two arguments are for logging & third is for the continuation, in need of `Ctx`. + +Once these arguments are given to this function, it will give `Ctx` to the continuation, where the logging part (the `ctxLog`) of `Ctx` would be obtained from the first two arguments of this function. + +The first argument is the log severity filter. Only logs of this severity or higher will be passed on to the second argument, which is a logging action. +-} newtype Setup = Setup (GYLogSeverity -> (String -> IO ()) -> (Ctx -> IO ()) -> IO ()) cardanoDefaultTestnetOptionsConway :: CardanoTestnetOptions cardanoDefaultTestnetOptionsConway = cardanoDefaultTestnetOptions {cardanoNodeEra = Api.AnyCardanoEra Api.ConwayEra} data PrivnetRuntime = PrivnetRuntime - { runtimeNodeSocket :: !FilePath + { runtimeNodeSocket :: !FilePath , runtimeNetworkInfo :: !GYNetworkInfo - , runtimeWallets :: ![PaymentKeyInfo] - , runtimeThreadId :: !ThreadId + , runtimeWallets :: ![PaymentKeyInfo] + , runtimeThreadId :: !ThreadId } {-# DEPRECATED withSetupOld "Use withSetup." #-} @@ -90,7 +95,7 @@ withSetup = withSetup' GYInfo -- | Calls the `Setup` function with target logging severity, a logging function and the action you wish to use with the privnet. withSetup' :: GYLogSeverity -> (String -> IO ()) -> Setup -> (Ctx -> IO ()) -> IO () withSetup' targetSev putLog (Setup cokont) kont = do - cokont targetSev putLog kont + cokont targetSev putLog kont -- | Given a test name, runs the test under privnet. mkPrivnetTestFor :: TestName -> Setup -> (TestInfo -> GYTxGameMonadIO ()) -> TestTree @@ -99,7 +104,7 @@ mkPrivnetTestFor name = mkPrivnetTestFor' name GYInfo -- | Given a test name, runs the test under privnet with target logging severity. mkPrivnetTestFor' :: TestName -> GYLogSeverity -> Setup -> (TestInfo -> GYTxGameMonadIO ()) -> TestTree mkPrivnetTestFor' name targetSev setup action = testCaseSteps name $ \info -> withSetup' targetSev info setup $ \ctx -> do - ctxRunGame ctx $ action TestInfo { testGoldAsset = ctxGold ctx, testIronAsset = ctxIron ctx, testWallets = ctxWallets ctx } + ctxRunGame ctx $ action TestInfo {testGoldAsset = ctxGold ctx, testIronAsset = ctxIron ctx, testWallets = ctxWallets ctx} {- TODO: WIP: Provide a variant of `withSetup` that can access `Ctx` to return a non-unit result. @@ -123,45 +128,48 @@ debug _ = return () conwayGenesis :: ConwayGenesis StandardCrypto conwayGenesis = let upPParams :: UpgradeConwayPParams Identity - upPParams = UpgradeConwayPParams - { ucppPoolVotingThresholds = poolVotingThresholds - , ucppDRepVotingThresholds = drepVotingThresholds - , ucppCommitteeMinSize = 0 - , ucppCommitteeMaxTermLength = EpochInterval 200 - , ucppGovActionLifetime = EpochInterval 1 -- One Epoch - , ucppGovActionDeposit = Coin 1_000_000 - , ucppDRepDeposit = Coin 1_000_000 - , ucppDRepActivity = EpochInterval 100 - , ucppMinFeeRefScriptCostPerByte = 15 %! 1 - , ucppPlutusV3CostModel = either (error "Couldn't build PlutusV3 cost models") id $ Ledger.mkCostModel Ledger.PlutusV3 [100788, 420, 1, 1, 1000, 173, 0, 1, 1000, 59957, 4, 1, 11183, 32, 201305, 8356, 4, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 100, 100, 16000, 100, 94375, 32, 132994, 32, 61462, 4, 72010, 178, 0, 1, 22151, 32, 91189, 769, 4, 2, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 1000, 42921, 4, 2, 24548, 29498, 38, 1, 898148, 27279, 1, 51775, 558, 1, 39184, 1000, 60594, 1, 141895, 32, 83150, 32, 15299, 32, 76049, 1, 13169, 4, 22100, 10, 28999, 74, 1, 28999, 74, 1, 43285, 552, 1, 44749, 541, 1, 33852, 32, 68246, 32, 72362, 32, 7243, 32, 7391, 32, 11546, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 90434, 519, 0, 1, 74433, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 955506, 213312, 0, 2, 270652, 22588, 4, 1457325, 64566, 4, 20467, 1, 4, 0, 141992, 32, 100788, 420, 1, 1, 81663, 32, 59498, 32, 20142, 32, 24588, 32, 20744, 32, 25933, 32, 24623, 32, 43053543, 10, 53384111, 14333, 10, 43574283, 26308, 10, 16000, 100, 16000, 100, 962335, 18, 2780678, 6, 442008, 1, 52538055, 3756, 18, 267929, 18, 76433006, 8868, 18, 52948122, 18, 1995836, 36, 3227919, 12, 901022, 1, 166917843, 4307, 36, 284546, 36, 158221314, 26549, 36, 74698472, 36, 333849714, 1, 254006273, 72, 2174038, 72, 2261318, 64571, 4, 207616, 8310, 4, 1293828, 28716, 63, 0, 1, 1006041, 43623, 251, 0, 1] - } - drepVotingThresholds = DRepVotingThresholds - { dvtMotionNoConfidence = 67 %! 100 - , dvtCommitteeNormal = 67 %! 100 - , dvtCommitteeNoConfidence = 6 %! 10 - , dvtUpdateToConstitution = 75 %! 100 - , dvtHardForkInitiation = 6 %! 10 - , dvtPPNetworkGroup = 67 %! 100 - , dvtPPEconomicGroup = 67 %! 100 - , dvtPPTechnicalGroup = 67 %! 100 - , dvtPPGovGroup = 75 %! 100 - , dvtTreasuryWithdrawal = 67 %! 100 - } - poolVotingThresholds = PoolVotingThresholds - { pvtMotionNoConfidence = commonPoolVotingThreshold - , pvtCommitteeNormal = commonPoolVotingThreshold - , pvtCommitteeNoConfidence = commonPoolVotingThreshold - , pvtHardForkInitiation = commonPoolVotingThreshold - , pvtPPSecurityGroup = commonPoolVotingThreshold - } + upPParams = + UpgradeConwayPParams + { ucppPoolVotingThresholds = poolVotingThresholds + , ucppDRepVotingThresholds = drepVotingThresholds + , ucppCommitteeMinSize = 0 + , ucppCommitteeMaxTermLength = EpochInterval 200 + , ucppGovActionLifetime = EpochInterval 1 -- One Epoch + , ucppGovActionDeposit = Coin 1_000_000 + , ucppDRepDeposit = Coin 1_000_000 + , ucppDRepActivity = EpochInterval 100 + , ucppMinFeeRefScriptCostPerByte = 15 %! 1 + , ucppPlutusV3CostModel = either (error "Couldn't build PlutusV3 cost models") id $ Ledger.mkCostModel Ledger.PlutusV3 [100788, 420, 1, 1, 1000, 173, 0, 1, 1000, 59957, 4, 1, 11183, 32, 201305, 8356, 4, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 16000, 100, 100, 100, 16000, 100, 94375, 32, 132994, 32, 61462, 4, 72010, 178, 0, 1, 22151, 32, 91189, 769, 4, 2, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 1000, 42921, 4, 2, 24548, 29498, 38, 1, 898148, 27279, 1, 51775, 558, 1, 39184, 1000, 60594, 1, 141895, 32, 83150, 32, 15299, 32, 76049, 1, 13169, 4, 22100, 10, 28999, 74, 1, 28999, 74, 1, 43285, 552, 1, 44749, 541, 1, 33852, 32, 68246, 32, 72362, 32, 7243, 32, 7391, 32, 11546, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 90434, 519, 0, 1, 74433, 32, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 1, 85848, 123203, 7305, -900, 1716, 549, 57, 85848, 0, 1, 955506, 213312, 0, 2, 270652, 22588, 4, 1457325, 64566, 4, 20467, 1, 4, 0, 141992, 32, 100788, 420, 1, 1, 81663, 32, 59498, 32, 20142, 32, 24588, 32, 20744, 32, 25933, 32, 24623, 32, 43053543, 10, 53384111, 14333, 10, 43574283, 26308, 10, 16000, 100, 16000, 100, 962335, 18, 2780678, 6, 442008, 1, 52538055, 3756, 18, 267929, 18, 76433006, 8868, 18, 52948122, 18, 1995836, 36, 3227919, 12, 901022, 1, 166917843, 4307, 36, 284546, 36, 158221314, 26549, 36, 74698472, 36, 333849714, 1, 254006273, 72, 2174038, 72, 2261318, 64571, 4, 207616, 8310, 4, 1293828, 28716, 63, 0, 1, 1006041, 43623, 251, 0, 1] + } + drepVotingThresholds = + DRepVotingThresholds + { dvtMotionNoConfidence = 67 %! 100 + , dvtCommitteeNormal = 67 %! 100 + , dvtCommitteeNoConfidence = 6 %! 10 + , dvtUpdateToConstitution = 75 %! 100 + , dvtHardForkInitiation = 6 %! 10 + , dvtPPNetworkGroup = 67 %! 100 + , dvtPPEconomicGroup = 67 %! 100 + , dvtPPTechnicalGroup = 67 %! 100 + , dvtPPGovGroup = 75 %! 100 + , dvtTreasuryWithdrawal = 67 %! 100 + } + poolVotingThresholds = + PoolVotingThresholds + { pvtMotionNoConfidence = commonPoolVotingThreshold + , pvtCommitteeNormal = commonPoolVotingThreshold + , pvtCommitteeNoConfidence = commonPoolVotingThreshold + , pvtHardForkInitiation = commonPoolVotingThreshold + , pvtPPSecurityGroup = commonPoolVotingThreshold + } commonPoolVotingThreshold = 51 %! 100 - in ConwayGenesis - { cgUpgradePParams = upPParams - , cgConstitution = DefaultClass.def - , cgCommittee = DefaultClass.def - , cgDelegs = mempty - , cgInitialDReps = mempty - } + in ConwayGenesis + { cgUpgradePParams = upPParams + , cgConstitution = DefaultClass.def + , cgCommittee = DefaultClass.def + , cgDelegs = mempty + , cgInitialDReps = mempty + } {- | Spawn a resource managed privnet and do things with it (closing it in the end). @@ -175,174 +183,183 @@ given a logging -- function and the action itself (which receives the Privnet Ct -} withPrivnet :: CardanoTestnetOptions -> (Setup -> IO ()) -> IO () withPrivnet testnetOpts setupUser = do - -- Based on: https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Property/Run.hs - -- They are using hedgehog (property testing framework) to orchestrate a testnet running in the background - -- ....for some god forsaken reason - -- the result is very awkward. - tmvRuntime <- STM.newEmptyTMVarIO - - void . H.check $ integrationWorkspace "tn" $ \workspaceDir -> do - conf <- mkConf workspaceDir - - -- Fork a thread to keep alive indefinitely any resources allocated by testnet. - threadId <- H.evalM . liftResourceT . resourceForkIO . forever . liftIO $ threadDelay 10000000 - - TestnetRuntime - { wallets - , poolNodes - , testnetMagic - } <- cardanoTestnet' testnetOpts conf - - liftIO . STM.atomically - $ STM.writeTMVar tmvRuntime PrivnetRuntime - -- TODO: Consider obtaining everything here from shelleyGenesis rather than testnetOpts. - -- See: https://www.doitwithlovelace.io/haddock/cardano-ledger-shelley/html/Cardano-Ledger-Shelley-Genesis.html - -- See: https://github.com/IntersectMBO/cardano-node/blob/43149909fc4942e93e14a2686826543a2d9432bf/cardano-testnet/src/Testnet/Types.hs#L155 - { runtimeNodeSocket = H'.sprocketSystemName - . nodeSprocket - . poolRuntime - $ head poolNodes - , runtimeNetworkInfo = GYNetworkInfo - { gyNetworkEpochSlots = fromIntegral $ cardanoEpochLength testnetOpts - , gyNetworkMagic = fromIntegral testnetMagic - } - , runtimeWallets = wallets - , runtimeThreadId = threadId + -- Based on: https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/src/Testnet/Property/Run.hs + -- They are using hedgehog (property testing framework) to orchestrate a testnet running in the background + -- ....for some god forsaken reason + -- the result is very awkward. + tmvRuntime <- STM.newEmptyTMVarIO + + void . H.check $ integrationWorkspace "tn" $ \workspaceDir -> do + conf <- mkConf workspaceDir + + -- Fork a thread to keep alive indefinitely any resources allocated by testnet. + threadId <- H.evalM . liftResourceT . resourceForkIO . forever . liftIO $ threadDelay 10000000 + + TestnetRuntime + { wallets + , poolNodes + , testnetMagic + } <- + cardanoTestnet' testnetOpts conf + + liftIO . STM.atomically $ + STM.writeTMVar + tmvRuntime + PrivnetRuntime + { -- TODO: Consider obtaining everything here from shelleyGenesis rather than testnetOpts. + -- See: https://www.doitwithlovelace.io/haddock/cardano-ledger-shelley/html/Cardano-Ledger-Shelley-Genesis.html + -- See: https://github.com/IntersectMBO/cardano-node/blob/43149909fc4942e93e14a2686826543a2d9432bf/cardano-testnet/src/Testnet/Types.hs#L155 + runtimeNodeSocket = + H'.sprocketSystemName + . nodeSprocket + . poolRuntime + $ head poolNodes + , runtimeNetworkInfo = + GYNetworkInfo + { gyNetworkEpochSlots = fromIntegral $ cardanoEpochLength testnetOpts + , gyNetworkMagic = fromIntegral testnetMagic } - - -- Forced failure (just like upstream). - -- For some god forsaken reason, not making this whole thing fail makes the node workspace directory disappear and the nodes not run. - -- Assumption: Hedgehog clears the workspace (since it's temp) in case of success. - -- No clue why the nodes don't run. Laziness? - H.failure - - PrivnetRuntime - { runtimeNodeSocket - , runtimeNetworkInfo - , runtimeWallets - , runtimeThreadId - } <- STM.atomically $ STM.readTMVar tmvRuntime - - let runtimeNetworkId = GYPrivnet runtimeNetworkInfo - - -- Kill the resource holding thread at the end of all this to stop the privnet. - (`finally` killThread runtimeThreadId) $ do - - -- Read pre-existing users. - -- NOTE: As of writing, cardano-testnet creates three (3) users. - genesisUsers <- fmap V.fromList . liftIO . forM (zip [1 :: Int ..] runtimeWallets) - $ \(idx, PaymentKeyInfo {paymentKeyInfoPair, paymentKeyInfoAddr}) -> do - debug $ printf "userF = %s\n" (show idx) - userAddr <- addressFromBech32 <$> urlPieceFromText paymentKeyInfoAddr - debug $ printf "userF addr = %s\n" userAddr - userPaymentSKey' <- readPaymentSigningKey $ Api.unFile $ signingKey paymentKeyInfoPair - debug $ printf "userF skey = %s\n" userPaymentSKey' - pure User' {userPaymentSKey', userStakeSKey'=Nothing, userAddr} - - -- Generate upto 9 users. - let extraIndices = [length genesisUsers + 1..9] - extraUsers <- fmap V.fromList . forM extraIndices $ \idx -> do - User' {userPaymentSKey', userAddr, userStakeSKey'} <- generateUser runtimeNetworkId - debug $ printf "user = %s\n" (show idx) - debug $ printf "user addr = %s\n" userAddr - debug $ printf "user skey = %s\n" (show userPaymentSKey') - debug $ printf "user vkey = %s\n" (show $ paymentVerificationKey userPaymentSKey') - debug $ printf "user pkh = %s\n" (show $ paymentKeyHash $ paymentVerificationKey userPaymentSKey') - pure User' {userPaymentSKey', userAddr, userStakeSKey'} - - -- Further down we need local node connection - let info :: Api.LocalNodeConnectInfo - info = Api.LocalNodeConnectInfo - { Api.localConsensusModeParams = Api.CardanoModeParams . Api.EpochSlots $ gyNetworkEpochSlots runtimeNetworkInfo - , Api.localNodeNetworkId = networkIdToApi runtimeNetworkId - , Api.localNodeSocketPath = Api.File runtimeNodeSocket - } - - -- ask current slot, so we know local node connection works - slot <- nodeGetSlotOfCurrentBlock info - debug $ printf "slotOfCurrentBlock = %s\n" slot - - withLCIClient info [] $ \lci -> do - let localLookupDatum :: GYLookupDatum - localLookupDatum = lciLookupDatum lci - - let localAwaitTxConfirmed :: GYAwaitTx - localAwaitTxConfirmed = nodeAwaitTxConfirmed info - - let localQueryUtxo :: GYQueryUTxO - localQueryUtxo = nodeQueryUTxO info - - localGetParams <- nodeGetParameters info - - -- context used for tests - -- - let allUsers = genesisUsers <> extraUsers - let ctx0 :: Ctx - ctx0 = Ctx - { ctxNetworkInfo = runtimeNetworkInfo - , ctxInfo = info - -- FIXME: Some of the users which are supposed to be non genesis are actually genesis. - -- This is because we have multiple genesis users with cardano testnet. - -- Need a better (more dynamic mechanism for users). - , ctxUserF = V.head allUsers - , ctxUser2 = allUsers V.! 1 - , ctxUser3 = allUsers V.! 2 - , ctxUser4 = allUsers V.! 3 - , ctxUser5 = allUsers V.! 4 - , ctxUser6 = allUsers V.! 5 - , ctxUser7 = allUsers V.! 6 - , ctxUser8 = allUsers V.! 7 - , ctxUser9 = allUsers V.! 8 - , ctxGold = GYLovelace -- temporarily - , ctxIron = GYLovelace -- temporarily - , ctxLog = noLogging - , ctxLookupDatum = localLookupDatum - , ctxAwaitTxConfirmed = localAwaitTxConfirmed - , ctxQueryUtxos = localQueryUtxo - , ctxGetParams = localGetParams - } - - V.imapM_ - (\i User'{userAddr=userIaddr} -> do - userIbalance <- ctxRunQuery ctx0 $ queryBalance userIaddr - when (isEmptyValue userIbalance) $ do - debug $ printf "User %d balance is empty, giving some ada\n" $ i + 1 - giveAda ctx0 userIaddr - when (i == 0) (giveAda ctx0 . userAddr $ ctxUserF ctx0) -- we also give ada to itself to create some small utxos - ) allUsers - - -- mint test tokens - goldAC <- mintTestTokens ctx0 "GOLD" - debug $ printf "gold = %s\n" goldAC - - ironAC <- mintTestTokens ctx0 "IRON" - debug $ printf "iron = %s\n" ironAC - - let ctx :: Ctx - ctx = ctx0 - { ctxGold = goldAC - , ctxIron = ironAC - } - - -- distribute tokens - V.imapM_ - (\i User'{userAddr=userIaddr} -> do - userIbalance <- ctxRunQuery ctx0 $ queryBalance userIaddr - when (isEmptyValue $ snd $ valueSplitAda userIbalance) $ do - debug $ printf "User %d has no tokens, giving some\n" $ i + 1 - giveTokens ctx userIaddr - ) - allUsers - - let setup = Setup $ \targetSev putLog kont -> kont $ ctx { ctxLog = simpleLogging targetSev (putLog . Txt.unpack) } - setupUser setup + , runtimeWallets = wallets + , runtimeThreadId = threadId + } + + -- Forced failure (just like upstream). + -- For some god forsaken reason, not making this whole thing fail makes the node workspace directory disappear and the nodes not run. + -- Assumption: Hedgehog clears the workspace (since it's temp) in case of success. + -- No clue why the nodes don't run. Laziness? + H.failure + + PrivnetRuntime + { runtimeNodeSocket + , runtimeNetworkInfo + , runtimeWallets + , runtimeThreadId + } <- + STM.atomically $ STM.readTMVar tmvRuntime + + let runtimeNetworkId = GYPrivnet runtimeNetworkInfo + + -- Kill the resource holding thread at the end of all this to stop the privnet. + (`finally` killThread runtimeThreadId) $ do + -- Read pre-existing users. + -- NOTE: As of writing, cardano-testnet creates three (3) users. + genesisUsers <- fmap V.fromList . liftIO . forM (zip [1 :: Int ..] runtimeWallets) $ + \(idx, PaymentKeyInfo {paymentKeyInfoPair, paymentKeyInfoAddr}) -> do + debug $ printf "userF = %s\n" (show idx) + userAddr <- addressFromBech32 <$> urlPieceFromText paymentKeyInfoAddr + debug $ printf "userF addr = %s\n" userAddr + userPaymentSKey' <- readPaymentSigningKey $ Api.unFile $ signingKey paymentKeyInfoPair + debug $ printf "userF skey = %s\n" userPaymentSKey' + pure User' {userPaymentSKey', userStakeSKey' = Nothing, userAddr} + + -- Generate upto 9 users. + let extraIndices = [length genesisUsers + 1 .. 9] + extraUsers <- fmap V.fromList . forM extraIndices $ \idx -> do + User' {userPaymentSKey', userAddr, userStakeSKey'} <- generateUser runtimeNetworkId + debug $ printf "user = %s\n" (show idx) + debug $ printf "user addr = %s\n" userAddr + debug $ printf "user skey = %s\n" (show userPaymentSKey') + debug $ printf "user vkey = %s\n" (show $ paymentVerificationKey userPaymentSKey') + debug $ printf "user pkh = %s\n" (show $ paymentKeyHash $ paymentVerificationKey userPaymentSKey') + pure User' {userPaymentSKey', userAddr, userStakeSKey'} + + -- Further down we need local node connection + let info :: Api.LocalNodeConnectInfo + info = + Api.LocalNodeConnectInfo + { Api.localConsensusModeParams = Api.CardanoModeParams . Api.EpochSlots $ gyNetworkEpochSlots runtimeNetworkInfo + , Api.localNodeNetworkId = networkIdToApi runtimeNetworkId + , Api.localNodeSocketPath = Api.File runtimeNodeSocket + } + + -- ask current slot, so we know local node connection works + slot <- nodeGetSlotOfCurrentBlock info + debug $ printf "slotOfCurrentBlock = %s\n" slot + + withLCIClient info [] $ \lci -> do + let localLookupDatum :: GYLookupDatum + localLookupDatum = lciLookupDatum lci + + let localAwaitTxConfirmed :: GYAwaitTx + localAwaitTxConfirmed = nodeAwaitTxConfirmed info + + let localQueryUtxo :: GYQueryUTxO + localQueryUtxo = nodeQueryUTxO info + + localGetParams <- nodeGetParameters info + + -- context used for tests + -- + let allUsers = genesisUsers <> extraUsers + let ctx0 :: Ctx + ctx0 = + Ctx + { ctxNetworkInfo = runtimeNetworkInfo + , ctxInfo = info + , -- FIXME: Some of the users which are supposed to be non genesis are actually genesis. + -- This is because we have multiple genesis users with cardano testnet. + -- Need a better (more dynamic mechanism for users). + ctxUserF = V.head allUsers + , ctxUser2 = allUsers V.! 1 + , ctxUser3 = allUsers V.! 2 + , ctxUser4 = allUsers V.! 3 + , ctxUser5 = allUsers V.! 4 + , ctxUser6 = allUsers V.! 5 + , ctxUser7 = allUsers V.! 6 + , ctxUser8 = allUsers V.! 7 + , ctxUser9 = allUsers V.! 8 + , ctxGold = GYLovelace -- temporarily + , ctxIron = GYLovelace -- temporarily + , ctxLog = noLogging + , ctxLookupDatum = localLookupDatum + , ctxAwaitTxConfirmed = localAwaitTxConfirmed + , ctxQueryUtxos = localQueryUtxo + , ctxGetParams = localGetParams + } + + V.imapM_ + ( \i User' {userAddr = userIaddr} -> do + userIbalance <- ctxRunQuery ctx0 $ queryBalance userIaddr + when (isEmptyValue userIbalance) $ do + debug $ printf "User %d balance is empty, giving some ada\n" $ i + 1 + giveAda ctx0 userIaddr + when (i == 0) (giveAda ctx0 . userAddr $ ctxUserF ctx0) -- we also give ada to itself to create some small utxos + ) + allUsers + + -- mint test tokens + goldAC <- mintTestTokens ctx0 "GOLD" + debug $ printf "gold = %s\n" goldAC + + ironAC <- mintTestTokens ctx0 "IRON" + debug $ printf "iron = %s\n" ironAC + + let ctx :: Ctx + ctx = + ctx0 + { ctxGold = goldAC + , ctxIron = ironAC + } + + -- distribute tokens + V.imapM_ + ( \i User' {userAddr = userIaddr} -> do + userIbalance <- ctxRunQuery ctx0 $ queryBalance userIaddr + when (isEmptyValue $ snd $ valueSplitAda userIbalance) $ do + debug $ printf "User %d has no tokens, giving some\n" $ i + 1 + giveTokens ctx userIaddr + ) + allUsers + + let setup = Setup $ \targetSev putLog kont -> kont $ ctx {ctxLog = simpleLogging targetSev (putLog . Txt.unpack)} + setupUser setup where - -- | This is defined same as `cardanoTestnetDefault` except we use our own conway genesis parameters. + -- \| This is defined same as `cardanoTestnetDefault` except we use our own conway genesis parameters. cardanoTestnet' opts conf = do - Api.AnyCardanoEra cEra <- pure $ cardanoNodeEra cardanoDefaultTestnetOptions - alonzoGenesis <- getDefaultAlonzoGenesis cEra - (startTime, shelleyGenesis') <- getDefaultShelleyGenesis opts - cardanoTestnet opts conf startTime shelleyGenesis' alonzoGenesis conwayGenesis + Api.AnyCardanoEra cEra <- pure $ cardanoNodeEra cardanoDefaultTestnetOptions + alonzoGenesis <- getDefaultAlonzoGenesis cEra + (startTime, shelleyGenesis') <- getDefaultShelleyGenesis opts + cardanoTestnet opts conf startTime shelleyGenesis' alonzoGenesis conwayGenesis ------------------------------------------------------------------------------- -- Generating users @@ -351,25 +368,27 @@ withPrivnet testnetOpts setupUser = do -- TODO (simplify-genesis): Remove this. See note 'simplify-genesis'. generateUser :: GYNetworkId -> IO User generateUser network = do - -- generate new key - skey <- Api.generateSigningKey Api.AsPaymentKey + -- generate new key + skey <- Api.generateSigningKey Api.AsPaymentKey - -- construct address (no stake) - let vkey = Api.getVerificationKey skey - vkeyHash = Api.verificationKeyHash vkey + -- construct address (no stake) + let vkey = Api.getVerificationKey skey + vkeyHash = Api.verificationKeyHash vkey - let addr :: GYAddress - addr = addressFromApi' $ Api.AddressInEra + let addr :: GYAddress + addr = + addressFromApi' $ + Api.AddressInEra (Api.ShelleyAddressInEra Api.ShelleyBasedEraConway) - (Api.makeShelleyAddress + ( Api.makeShelleyAddress (networkIdToApi network) (Api.PaymentCredentialByKey vkeyHash) stake ) - pure User' {userPaymentSKey'=paymentSigningKeyFromApi skey, userAddr=addr, userStakeSKey'=Nothing} + pure User' {userPaymentSKey' = paymentSigningKeyFromApi skey, userAddr = addr, userStakeSKey' = Nothing} where - stake = Api.NoStakeAddress + stake = Api.NoStakeAddress ------------------------------------------------------------------------------- -- Balance @@ -378,17 +397,22 @@ generateUser network = do -- TODO (simplify-genesis): Remove this once 'generateUser' and similar have been removed. Use 'createUserWithLovelace' instead. giveAda :: Ctx -> GYAddress -> IO () giveAda ctx addr = ctxRun ctx (ctxUserF ctx) $ do - txBody <- buildTxBody $ mconcat $ replicate 5 $ - mustHaveOutput $ mkGYTxOutNoDatum addr (valueFromLovelace 1_000_000_000) - signAndSubmitConfirmed_ txBody + txBody <- + buildTxBody $ + mconcat $ + replicate 5 $ + mustHaveOutput $ + mkGYTxOutNoDatum addr (valueFromLovelace 1_000_000_000) + signAndSubmitConfirmed_ txBody -- TODO (simplify-genesis): Remove this once 'generateUser' and similar have been removed. Use 'createUserWithAssets' instead. giveTokens :: Ctx -> GYAddress -> IO () giveTokens ctx addr = ctxRun ctx (ctxUserF ctx) $ do - txBody <- buildTxBody $ - mustHaveOutput (mkGYTxOutNoDatum addr (valueSingleton (ctxGold ctx) 10_000_000)) <> - mustHaveOutput (mkGYTxOutNoDatum addr (valueSingleton (ctxIron ctx) 10_000_000)) - signAndSubmitConfirmed_ txBody + txBody <- + buildTxBody $ + mustHaveOutput (mkGYTxOutNoDatum addr (valueSingleton (ctxGold ctx) 10_000_000)) + <> mustHaveOutput (mkGYTxOutNoDatum addr (valueSingleton (ctxIron ctx) 10_000_000)) + signAndSubmitConfirmed_ txBody ------------------------------------------------------------------------------- -- minting tokens @@ -397,10 +421,10 @@ giveTokens ctx addr = ctxRun ctx (ctxUserF ctx) $ do -- TODO (simplify-genesis): Remove this once 'generateUser' and similar have been removed. mintTestTokens :: Ctx -> String -> IO GYAssetClass mintTestTokens ctx tn' = do - ctxRun ctx (ctxUserF ctx) $ do - (ac, txBody) <- GY.TestTokens.mintTestTokens tn 1_000_000_000 >>= traverse buildTxBody - signAndSubmitConfirmed_ txBody - pure ac + ctxRun ctx (ctxUserF ctx) $ do + (ac, txBody) <- GY.TestTokens.mintTestTokens tn 1_000_000_000 >>= traverse buildTxBody + signAndSubmitConfirmed_ txBody + pure ac where tn :: GYTokenName tn = fromString tn' diff --git a/src/GeniusYield/Test/Privnet/Utils.hs b/src/GeniusYield/Test/Privnet/Utils.hs index 5ddb8ee7..8baeadf0 100644 --- a/src/GeniusYield/Test/Privnet/Utils.hs +++ b/src/GeniusYield/Test/Privnet/Utils.hs @@ -1,44 +1,42 @@ -{-| +{- | Module : GeniusYield.Test.Privnet.Utils Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Test.Privnet.Utils ( - die, - urlPieceFromFile, - urlPieceToFile, - urlPieceFromText, + die, + urlPieceFromFile, + urlPieceToFile, + urlPieceFromText, ) where -import Data.Text (Text) -import System.Exit (exitFailure) -import Text.Printf (printf) -import Type.Reflection (Typeable, typeRep) +import Data.Text (Text) +import System.Exit (exitFailure) +import Text.Printf (printf) +import Type.Reflection (Typeable, typeRep) -import qualified Data.Text.IO as T.IO -import qualified Web.HttpApiData as Web +import Data.Text.IO qualified as T.IO +import Web.HttpApiData qualified as Web die :: String -> IO a die msg = do - putStrLn msg - exitFailure + putStrLn msg + exitFailure urlPieceFromFile :: forall a. (Typeable a, Web.FromHttpApiData a) => FilePath -> IO a urlPieceFromFile p = do - t <- T.IO.readFile p - urlPieceFromText @a t + t <- T.IO.readFile p + urlPieceFromText @a t urlPieceFromText :: forall a. (Typeable a, Web.FromHttpApiData a) => Text -> IO a urlPieceFromText t = case Web.parseUrlPiece t of - Right x -> - return x - - Left msg -> do - printf "Failed to parse %s from %s: %s\n" (show (typeRep @a)) t msg - exitFailure + Right x -> + return x + Left msg -> do + printf "Failed to parse %s from %s: %s\n" (show (typeRep @a)) t msg + exitFailure -urlPieceToFile :: forall a. Web.ToHttpApiData a => FilePath -> a -> IO () +urlPieceToFile :: forall a. (Web.ToHttpApiData a) => FilePath -> a -> IO () urlPieceToFile p x = T.IO.writeFile p (Web.toUrlPiece x) diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index aa79cb21..1ad18f42 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -1,52 +1,55 @@ {-# LANGUAGE PatternSynonyms #-} -{-| +{- | Module : GeniusYield.Test.Utils Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Test.Utils - ( TestInfo (..) - , Wallets (..) - , createUserWithLovelace - , createUserWithAssets - , createUserFull - , withBalance - , withWalletBalancesCheck - , findLockedUtxosInBody - , getRefInfos - , findRefScriptsInBody - , addRefScript - , addRefInput - , mintTestAssets - , generateCollateral - , fakeValue, fakeCoin, fakeGold, fakeIron, fakePolicy - , afterAllSucceed - , feesFromLovelace - , withMaxQCTests - , pattern (:=) - , module X - ) where - -import Control.Monad.Except (ExceptT, runExceptT) -import Control.Monad.Random -import qualified Data.Map.Strict as Map -import qualified Data.Text as T - -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.QuickCheck as Tasty -import qualified Test.Tasty.Runners as Tasty - -import GeniusYield.HTTP.Errors -import GeniusYield.Imports -import GeniusYield.Test.FakeCoin -import GeniusYield.TxBuilder -import GeniusYield.Types - -import GeniusYield.Test.FeeTracker as X +module GeniusYield.Test.Utils ( + TestInfo (..), + Wallets (..), + createUserWithLovelace, + createUserWithAssets, + createUserFull, + withBalance, + withWalletBalancesCheck, + findLockedUtxosInBody, + getRefInfos, + findRefScriptsInBody, + addRefScript, + addRefInput, + mintTestAssets, + generateCollateral, + fakeValue, + fakeCoin, + fakeGold, + fakeIron, + fakePolicy, + afterAllSucceed, + feesFromLovelace, + withMaxQCTests, + pattern (:=), + module X, +) where + +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Random +import Data.Map.Strict qualified as Map +import Data.Text qualified as T + +import Test.Tasty qualified as Tasty +import Test.Tasty.QuickCheck qualified as Tasty +import Test.Tasty.Runners qualified as Tasty + +import GeniusYield.HTTP.Errors +import GeniusYield.Imports +import GeniusYield.Test.FakeCoin +import GeniusYield.TxBuilder +import GeniusYield.Types + +import GeniusYield.Test.FeeTracker as X ------------------------------------------------------------------------------- -- tasty tools @@ -54,15 +57,16 @@ import GeniusYield.Test.FeeTracker as X -- | Runs the second 'Tasty.TestTree' after all tests in the first 'Tasty.TestTree' succeed afterAllSucceed :: Tasty.TestTree -> Tasty.TestTree -> Tasty.TestTree -afterAllSucceed = Tasty.after Tasty.AllSucceed . pat where +afterAllSucceed = Tasty.after Tasty.AllSucceed . pat + where pat :: Tasty.TestTree -> String pat dep = case dep of - Tasty.SingleTest tn _ -> tn - Tasty.TestGroup tn _ -> tn - Tasty.After _ _ dep' -> pat dep' - Tasty.PlusTestOptions _ dep' -> pat dep' - Tasty.WithResource _ f -> pat (f (fail "Not running IO")) - Tasty.AskOptions f -> pat (f mempty) + Tasty.SingleTest tn _ -> tn + Tasty.TestGroup tn _ -> tn + Tasty.After _ _ dep' -> pat dep' + Tasty.PlusTestOptions _ dep' -> pat dep' + Tasty.WithResource _ f -> pat (f (fail "Not running IO")) + Tasty.AskOptions f -> pat (f mempty) ------------------------------------------------------------------------------- -- QC @@ -70,7 +74,8 @@ afterAllSucceed = Tasty.after Tasty.AllSucceed . pat where -- | Adjust the number of QuickCheck cases to generate. withMaxQCTests :: Int -> Tasty.TestTree -> Tasty.TestTree -withMaxQCTests n = Tasty.adjustOption f where +withMaxQCTests n = Tasty.adjustOption f + where f :: Tasty.QuickCheckTests -> Tasty.QuickCheckTests f (Tasty.QuickCheckTests m) = Tasty.QuickCheckTests (min m n) @@ -106,43 +111,53 @@ TL;DR: Remove all user creation code from test setups and point Atlas users to u -- TODO (simplify-genesis): Remove 'TestInfo'. The only thing test setup should do is to make one or more genesis/funder user(s) -- and pass that 'User' onto the tests. + -- | General information about the test environment to help in running polymorphic tests. -data TestInfo = TestInfo { testGoldAsset :: !GYAssetClass, testIronAsset :: !GYAssetClass, testWallets :: !Wallets } +data TestInfo = TestInfo {testGoldAsset :: !GYAssetClass, testIronAsset :: !GYAssetClass, testWallets :: !Wallets} -- TODO (simplify-genesis): Remove this type once user creation logic is removed from test setup. + -- | Available wallets. data Wallets = Wallets - { w1 :: !User - , w2 :: !User - , w3 :: !User - , w4 :: !User - , w5 :: !User - , w6 :: !User - , w7 :: !User - , w8 :: !User - , w9 :: !User - } deriving (Show, Eq, Ord) + { w1 :: !User + , w2 :: !User + , w3 :: !User + , w4 :: !User + , w5 :: !User + , w6 :: !User + , w7 :: !User + , w8 :: !User + , w9 :: !User + } + deriving (Show, Eq, Ord) -- | Create an user and fund them with the given amount of lovelace provided by the given funder user. -createUserWithLovelace :: GYTxGameMonad m => User -> Natural -> m User +createUserWithLovelace :: (GYTxGameMonad m) => User -> Natural -> m User createUserWithLovelace funder lovelace = do - u <- createUser - asUser funder $ do - -- Fragment the lovelace amount into at least 5 utxos. - let utxosCount = 5 - eachUtxo = toInteger $ lovelace `quot` utxosCount - extraUtxo = toInteger $ lovelace `rem` utxosCount - mustHaveLovelace 0 = mempty - mustHaveLovelace l = mustHaveOutput $ mkGYTxOutNoDatum (userChangeAddress u) (valueFromLovelace l) - gyLogDebug' "createUserWithLovelace" . T.unpack - $ "Funding user at address: " <> addressToText (userChangeAddress u) <> "\n" - <> " number of new utxos (except extra): " <> T.pack (show utxosCount) <> "\n" - <> " lovelaces in each utxo: " <> T.pack (show eachUtxo) <> "\n" - <> " extra utxo: " <> T.pack (show extraUtxo) - - txBody <- buildTxBody $ mconcat $ mustHaveLovelace extraUtxo : replicate 5 (mustHaveLovelace eachUtxo) - signAndSubmitConfirmed_ txBody - pure u + u <- createUser + asUser funder $ do + -- Fragment the lovelace amount into at least 5 utxos. + let utxosCount = 5 + eachUtxo = toInteger $ lovelace `quot` utxosCount + extraUtxo = toInteger $ lovelace `rem` utxosCount + mustHaveLovelace 0 = mempty + mustHaveLovelace l = mustHaveOutput $ mkGYTxOutNoDatum (userChangeAddress u) (valueFromLovelace l) + gyLogDebug' "createUserWithLovelace" . T.unpack $ + "Funding user at address: " + <> addressToText (userChangeAddress u) + <> "\n" + <> " number of new utxos (except extra): " + <> T.pack (show utxosCount) + <> "\n" + <> " lovelaces in each utxo: " + <> T.pack (show eachUtxo) + <> "\n" + <> " extra utxo: " + <> T.pack (show extraUtxo) + + txBody <- buildTxBody $ mconcat $ mustHaveLovelace extraUtxo : replicate 5 (mustHaveLovelace eachUtxo) + signAndSubmitConfirmed_ txBody + pure u {- | `createUserWithAssets funder lovelaces tokens` is equivalent to `createUserWithLovelace funder lovelace', followed by 'mintTestAssets tokens' @@ -151,62 +166,72 @@ createUserWithLovelace funder lovelace = do Note: This will obviously require the user to have enough lovelace to cover the fees and min ada deposits for the mints. -} -createUserWithAssets :: GYTxGameMonad m => User -> Natural -> [(FakeCoin, Natural)] -> m User +createUserWithAssets :: (GYTxGameMonad m) => User -> Natural -> [(FakeCoin, Natural)] -> m User createUserWithAssets funder lovelace tokens = do - user <- createUserWithLovelace funder lovelace - asUser user $ mintTestAssets tokens - pure user + user <- createUserWithLovelace funder lovelace + asUser user $ mintTestAssets tokens + pure user -- | Create a collateral utxo out of the existing ada within a user wallet. Returns the collateral reference. -generateCollateral :: GYTxMonad m => m GYTxOutRef +generateCollateral :: (GYTxMonad m) => m GYTxOutRef generateCollateral = do - addr <- ownChangeAddress - gyLogDebug' "mintTestAssets" . T.unpack - $ "Generating collateral for: " <> addressToText addr <> "\n" - <> " collateral value: " <> T.pack (show collateralValue) - txBody <- buildTxBody $ mustHaveOutput (mkGYTxOutNoDatum addr collateralValue) - txId <- signAndSubmitConfirmed txBody - pure $ txOutRefFromTuple (txId, 0) - --- | This is a combination of 'createUserWithAssets' and 'generateCollateral'. --- It creates a user with ada, non-ada assets, and a collateral. --- Thereby making a user ready to participate in smart contracts. -createUserFull :: GYTxGameMonad m => User -> Natural -> [(FakeCoin, Natural)] -> m User + addr <- ownChangeAddress + gyLogDebug' "mintTestAssets" . T.unpack $ + "Generating collateral for: " + <> addressToText addr + <> "\n" + <> " collateral value: " + <> T.pack (show collateralValue) + txBody <- buildTxBody $ mustHaveOutput (mkGYTxOutNoDatum addr collateralValue) + txId <- signAndSubmitConfirmed txBody + pure $ txOutRefFromTuple (txId, 0) + +{- | This is a combination of 'createUserWithAssets' and 'generateCollateral'. +It creates a user with ada, non-ada assets, and a collateral. +Thereby making a user ready to participate in smart contracts. +-} +createUserFull :: (GYTxGameMonad m) => User -> Natural -> [(FakeCoin, Natural)] -> m User createUserFull funder lovelace tokens = do - user <- createUserWithAssets funder lovelace tokens - userCollateralRef <- asUser user generateCollateral - pure user { userCollateral = Just UserCollateral { userCollateralRef, userCollateralCheck = True } } + user <- createUserWithAssets funder lovelace tokens + userCollateralRef <- asUser user generateCollateral + pure user {userCollateral = Just UserCollateral {userCollateralRef, userCollateralCheck = True}} -- | Mint given amount of test tokens. -mintTestAssets :: GYTxMonad m => [(FakeCoin, Natural)] -> m () +mintTestAssets :: (GYTxMonad m) => [(FakeCoin, Natural)] -> m () mintTestAssets tokens = do - addr <- ownChangeAddress - let readableTkNames = map - (\(tk, amt) -> T.pack (show amt) <> " " <> readableTk tk) tokens - gyLogDebug' "mintTestAssets" . T.unpack - $ "Minting test assets for: " <> addressToText addr <> "\n" - <> "The test assets and their amounts are as following:-\n" - <> T.unlines (map (" " <>) readableTkNames) - txBody <- buildTxBody @PlutusV2 $ foldMap - (\(tk, amt) -> + addr <- ownChangeAddress + let readableTkNames = + map + (\(tk, amt) -> T.pack (show amt) <> " " <> readableTk tk) + tokens + gyLogDebug' "mintTestAssets" . T.unpack $ + "Minting test assets for: " + <> addressToText addr + <> "\n" + <> "The test assets and their amounts are as following:-\n" + <> T.unlines (map (" " <>) readableTkNames) + txBody <- + buildTxBody @PlutusV2 $ + foldMap + ( \(tk, amt) -> mustMint (GYMintScript $ fakePolicy tk) unitRedeemer (fakeCoinName tk) $ toInteger amt ) tokens - signAndSubmitConfirmed_ txBody + signAndSubmitConfirmed_ txBody where readableTk tk = mintingPolicyIdToText (mintingPolicyId $ fakePolicy tk) <> "." <> T.pack (show $ fakeCoinName tk) {- | Computes a `GYTx*Monad` action and returns the result and how this action changed the balance of some "Address". -} -withBalance :: GYTxQueryMonad m => String -> User -> m b -> m (b, GYValue) +withBalance :: (GYTxQueryMonad m) => String -> User -> m b -> m (b, GYValue) withBalance n a m = do - old <- queryBalance $ userAddr a - b <- m - new <- queryBalance $ userAddr a - let diff = new `valueMinus` old - gyLogDebug' "" $ printf "%s:\nold balance: %s\nnew balance: %s\ndiff: %s" n old new diff - return (b, diff) + old <- queryBalance $ userAddr a + b <- m + new <- queryBalance $ userAddr a + let diff = new `valueMinus` old + gyLogDebug' "" $ printf "%s:\nold balance: %s\nnew balance: %s\ndiff: %s" n old new diff + return (b, diff) {- | Computes a `GYTx*Monad` action, checking that the 'Wallet' balances change according to the input list. @@ -214,91 +239,106 @@ Notes: * An empty list means no checks are performed. * The 'GYValue' should be negative to check if the Wallet lost those funds. -} -withWalletBalancesCheck :: GYTxQueryMonad m => [(User, GYValue)] -> m a -> m a -withWalletBalancesCheck [] m = m +withWalletBalancesCheck :: (GYTxQueryMonad m) => [(User, GYValue)] -> m a -> m a +withWalletBalancesCheck [] m = m withWalletBalancesCheck ((w, v) : xs) m = do - (b, diff) <- withBalance (show $ userAddr w) w $ withWalletBalancesCheck xs m - unless (diff == v) $ do - throwAppError . someBackendError . T.pack $ printf "expected balance difference of %s for wallet %s, but the actual difference was %s" v (userAddr w) diff - return b + (b, diff) <- withBalance (show $ userAddr w) w $ withWalletBalancesCheck xs m + unless (diff == v) $ do + throwAppError . someBackendError . T.pack $ printf "expected balance difference of %s for wallet %s, but the actual difference was %s" v (userAddr w) diff + return b {- | Returns the list of outputs of the transaction for the given address. Returns Nothing if it fails to decode an address contained in the transaction outputs. -} -findLockedUtxosInBody :: Num a => GYAddress -> GYTx -> Maybe [a] +findLockedUtxosInBody :: (Num a) => GYAddress -> GYTx -> Maybe [a] findLockedUtxosInBody addr tx = let os = utxosToList . txBodyUTxOs $ getTxBody tx findAllMatches (_, [], acc) = Just acc - findAllMatches (index, txOut : os', acc) = if utxoAddress txOut == addr + findAllMatches (index, txOut : os', acc) = + if utxoAddress txOut == addr then findAllMatches (index + 1, os', index : acc) else findAllMatches (index + 1, os', acc) - in + in findAllMatches (0, os, []) -- | Find reference scripts at given address. -getRefInfos :: GYTxQueryMonad m => GYAddress -> m (Map GYAnyScript GYTxOutRef) +getRefInfos :: (GYTxQueryMonad m) => GYAddress -> m (Map GYAnyScript GYTxOutRef) getRefInfos addr = do - utxo <- utxosAtAddress addr Nothing - return $ utxoToRefMap utxo + utxo <- utxosAtAddress addr Nothing + return $ utxoToRefMap utxo -utxoToRefMap :: GYUTxOs -> Map GYAnyScript GYTxOutRef -utxoToRefMap utxo = Map.fromList +utxoToRefMap :: GYUTxOs -> Map GYAnyScript GYTxOutRef +utxoToRefMap utxo = + Map.fromList [ (sc, ref) - | GYUTxO { utxoRef = ref, utxoRefScript = Just sc} <- utxosToList utxo + | GYUTxO {utxoRef = ref, utxoRefScript = Just sc} <- utxosToList utxo ] -- | Find reference scripts in transaction body. findRefScriptsInBody :: GYTxBody -> Map GYAnyScript GYTxOutRef findRefScriptsInBody body = do - let utxo = txBodyUTxOs body - utxoToRefMap utxo + let utxo = txBodyUTxOs body + utxoToRefMap utxo --- | Adds the given script to the given address and returns the reference for it. --- Note: The new utxo is given an inline unit datum. -addRefScript :: forall m. GYTxMonad m => GYAddress -> GYScript 'PlutusV2 -> m GYTxOutRef -addRefScript addr sc = throwAppError absurdError `runEagerT` do +{- | Adds the given script to the given address and returns the reference for it. +Note: The new utxo is given an inline unit datum. +-} +addRefScript :: forall m. (GYTxMonad m) => GYAddress -> GYScript 'PlutusV2 -> m GYTxOutRef +addRefScript addr sc = + throwAppError absurdError `runEagerT` do existingUtxos <- lift $ utxosAtAddress addr Nothing let refs = utxoToRefMap existingUtxos maybeToEager $ Map.lookup (GYPlutusScript sc) refs - txBody <- lift $ buildTxBody - $ mustHaveOutput @'PlutusV2 GYTxOut - { gyTxOutAddress = addr - , gyTxOutValue = mempty - , gyTxOutDatum = Just (unitDatum, GYTxOutUseInlineDatum) - , gyTxOutRefS = Just $ GYPlutusScript sc - } + txBody <- + lift $ + buildTxBody $ + mustHaveOutput @'PlutusV2 + GYTxOut + { gyTxOutAddress = addr + , gyTxOutValue = mempty + , gyTxOutDatum = Just (unitDatum, GYTxOutUseInlineDatum) + , gyTxOutRefS = Just $ GYPlutusScript sc + } lift $ signAndSubmitConfirmed_ txBody maybeToEager . Map.lookup (GYPlutusScript sc) $ findRefScriptsInBody txBody where absurdError = someBackendError "Shouldn't happen: no ref in body" -- | Adds an input (whose datum we'll refer later) and returns the reference to it. -addRefInput :: GYTxMonad m - => Bool -- ^ Whether to inline this datum? - -> GYAddress -- ^ Where to place this output? - -> GYDatum -- ^ Our datum. - -> m GYTxOutRef -addRefInput toInline addr dat = throwAppError absurdError `runEagerT` do +addRefInput :: + (GYTxMonad m) => + -- | Whether to inline this datum? + Bool -> + -- | Where to place this output? + GYAddress -> + -- | Our datum. + GYDatum -> + m GYTxOutRef +addRefInput toInline addr dat = + throwAppError absurdError `runEagerT` do existingUtxos <- lift $ utxosAtAddress addr Nothing maybeToEager $ findRefWithDatum existingUtxos - txBody <- lift . buildTxBody . - mustHaveOutput @'PlutusV2 - $ GYTxOut addr mempty (Just (dat, if toInline then GYTxOutUseInlineDatum else GYTxOutDontUseInlineDatum)) Nothing + txBody <- + lift + . buildTxBody + . mustHaveOutput @'PlutusV2 + $ GYTxOut addr mempty (Just (dat, if toInline then GYTxOutUseInlineDatum else GYTxOutDontUseInlineDatum)) Nothing lift $ signAndSubmitConfirmed_ txBody maybeToEager . findRefWithDatum $ txBodyUTxOs txBody where findRefWithDatum :: GYUTxOs -> Maybe GYTxOutRef - findRefWithDatum utxos = fmap utxoRef + findRefWithDatum utxos = + fmap utxoRef . find - (\GYUTxO {utxoOutDatum} -> - case utxoOutDatum of - GYOutDatumHash dh -> hashDatum dat == dh - GYOutDatumInline dat' -> dat == dat' - _ -> False - ) + ( \GYUTxO {utxoOutDatum} -> + case utxoOutDatum of + GYOutDatumHash dh -> hashDatum dat == dh + GYOutDatumInline dat' -> dat == dat' + _ -> False + ) $ utxosToList utxos absurdError = someBackendError "Shouldn't happen: no output with expected datum in body" @@ -325,13 +365,14 @@ and that we can exit eagerly. -} type EagerT m a = ExceptT a m () --- | If we have a 'Just' value, we can exit with it immediately. So it gets converted --- to 'Left'. -maybeToEager :: Monad m => Maybe a -> EagerT m a +{- | If we have a 'Just' value, we can exit with it immediately. So it gets converted +to 'Left'. +-} +maybeToEager :: (Monad m) => Maybe a -> EagerT m a maybeToEager (Just a) = throwError a -maybeToEager Nothing = pure () +maybeToEager Nothing = pure () -- If all goes well, we should finish with a 'Left'. if not, we perform the -- given action to signal error. -runEagerT :: Monad m => m a -> ExceptT a m () -> m a +runEagerT :: (Monad m) => m a -> ExceptT a m () -> m a runEagerT whenError = runExceptT >=> either pure (const whenError) diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index d3b9b980..889ac01e 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.Transaction Description : Tools to build balanced transactions Copyright : (c) 2023 GYELD GMBH @@ -43,74 +43,81 @@ i.e. transaction mints tokens or consumes script outputs. See 'Api.evaluateTransactionBalance' and 'Api.makeTransactionBodyAutoBalance' (this function balances ADA only and doesn't add inputs, i.e. it calculates the ADA change). - -} module GeniusYield.Transaction ( - -- * Top level build interface - GYBuildTxEnv (..), - buildUnsignedTxBody, - GYBuildTxError (..), - GYCoinSelectionStrategy (..), - -- * Balancing only - balanceTxStep, - finalizeGYBalancedTx, - GYBalancingError (..), - -- * Utility type - GYTxInDetailed (..), + -- * Top level build interface + GYBuildTxEnv (..), + buildUnsignedTxBody, + GYBuildTxError (..), + GYCoinSelectionStrategy (..), + + -- * Balancing only + balanceTxStep, + finalizeGYBalancedTx, + GYBalancingError (..), + + -- * Utility type + GYTxInDetailed (..), ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Ledger as Ledger -import qualified Cardano.Api.Shelley as Api -import qualified Cardano.Api.Shelley as Api.S -import Cardano.Crypto.DSIGN (sizeSigDSIGN, - sizeVerKeyDSIGN) -import Cardano.Ledger.Alonzo.PParams (ppCollateralPercentageL) -import qualified Cardano.Ledger.Alonzo.PParams as Ledger -import qualified Cardano.Ledger.Alonzo.Scripts as AlonzoScripts -import qualified Cardano.Ledger.Alonzo.Tx as AlonzoTx -import qualified Cardano.Ledger.Binary as CBOR -import qualified Cardano.Ledger.Binary.Crypto as CBOR -import Cardano.Ledger.Core (EraTx (sizeTxF), - eraProtVerLow) -import qualified Cardano.Ledger.Core as Ledger -import Cardano.Ledger.Crypto (Crypto (..)) -import Cardano.Ledger.Era (Era (..)) -import Cardano.Ledger.Keys.WitVKey (WitVKey (..)) -import qualified Cardano.Ledger.Plutus as Ledger -import qualified Cardano.Ledger.Shelley.API.Wallet as Shelley -import Cardano.Slotting.Time (SystemStart) -import Control.Arrow ((&&&)) -import Control.Lens (view, (^.)) -import Control.Monad.Random -import Control.Monad.Trans.Except (runExceptT, throwE) -import qualified Data.ByteString.Lazy as LBS -import Data.Foldable (Foldable (foldMap'), - for_) -import Data.List (delete) -import qualified Data.Map as Map -import Data.Ratio ((%)) -import Data.Semigroup (Sum (..)) -import qualified Data.Set as Set -import GeniusYield.Imports -import GeniusYield.Transaction.CBOR -import GeniusYield.Transaction.CoinSelection -import GeniusYield.Transaction.Common -import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) -import GeniusYield.Types.TxCert.Internal +import Cardano.Api qualified as Api +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Crypto.DSIGN ( + sizeSigDSIGN, + sizeVerKeyDSIGN, + ) +import Cardano.Ledger.Alonzo.PParams (ppCollateralPercentageL) +import Cardano.Ledger.Alonzo.PParams qualified as Ledger +import Cardano.Ledger.Alonzo.Scripts qualified as AlonzoScripts +import Cardano.Ledger.Alonzo.Tx qualified as AlonzoTx +import Cardano.Ledger.Binary qualified as CBOR +import Cardano.Ledger.Binary.Crypto qualified as CBOR +import Cardano.Ledger.Core ( + EraTx (sizeTxF), + eraProtVerLow, + ) +import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Crypto (Crypto (..)) +import Cardano.Ledger.Era (Era (..)) +import Cardano.Ledger.Keys.WitVKey (WitVKey (..)) +import Cardano.Ledger.Plutus qualified as Ledger +import Cardano.Ledger.Shelley.API.Wallet qualified as Shelley +import Cardano.Slotting.Time (SystemStart) +import Control.Arrow ((&&&)) +import Control.Lens (view, (^.)) +import Control.Monad.Random +import Control.Monad.Trans.Except (runExceptT, throwE) +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable ( + Foldable (foldMap'), + for_, + ) +import Data.List (delete) +import Data.Map qualified as Map +import Data.Ratio ((%)) +import Data.Semigroup (Sum (..)) +import Data.Set qualified as Set +import GeniusYield.Imports +import GeniusYield.Transaction.CBOR +import GeniusYield.Transaction.CoinSelection +import GeniusYield.Transaction.Common +import GeniusYield.Types +import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) +import GeniusYield.Types.TxCert.Internal -- | A container for various network parameters, and user wallet information, used by balancer. data GYBuildTxEnv = GYBuildTxEnv - { gyBTxEnvSystemStart :: !SystemStart - , gyBTxEnvEraHistory :: !Api.EraHistory - , gyBTxEnvProtocolParams :: !ApiProtocolParameters - , gyBTxEnvPools :: !(Set Api.S.PoolId) - , gyBTxEnvOwnUtxos :: !GYUTxOs - -- ^ own utxos available for use as _additional_ input - , gyBTxEnvChangeAddr :: !GYAddress - , gyBTxEnvCollateral :: !GYUTxO - } + { gyBTxEnvSystemStart :: !SystemStart + , gyBTxEnvEraHistory :: !Api.EraHistory + , gyBTxEnvProtocolParams :: !ApiProtocolParameters + , gyBTxEnvPools :: !(Set Api.S.PoolId) + , gyBTxEnvOwnUtxos :: !GYUTxOs + -- ^ own utxos available for use as _additional_ input + , gyBTxEnvChangeAddr :: !GYAddress + , gyBTxEnvCollateral :: !GYUTxO + } ------------------------------------------------------------------------------- -- Top level wrappers around core balancing logic @@ -133,21 +140,26 @@ randImproveExtraLovelaceCeil :: Natural randImproveExtraLovelaceCeil = 20_000_000 -- | Pure interface to build the transaction body given necessary information. -buildUnsignedTxBody :: forall m v. - (HasCallStack, MonadRandom m) - => GYBuildTxEnv - -> GYCoinSelectionStrategy - -> [GYTxInDetailed v] - -> [GYTxOut v] - -> GYUTxOs -- ^ reference inputs - -> Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) -- ^ minted values - -> [GYTxWdrl v] -- ^ withdrawals - -> [GYTxCert v] -- ^ certificates - -> Maybe GYSlot - -> Maybe GYSlot - -> Set GYPubKeyHash - -> Maybe GYTxMetadata - -> m (Either GYBuildTxError GYTxBody) +buildUnsignedTxBody :: + forall m v. + (HasCallStack, MonadRandom m) => + GYBuildTxEnv -> + GYCoinSelectionStrategy -> + [GYTxInDetailed v] -> + [GYTxOut v] -> + -- | reference inputs + GYUTxOs -> + -- | minted values + Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) -> + -- | withdrawals + [GYTxWdrl v] -> + -- | certificates + [GYTxCert v] -> + Maybe GYSlot -> + Maybe GYSlot -> + Set GYPubKeyHash -> + Maybe GYTxMetadata -> + m (Either GYBuildTxError GYTxBody) buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub signers mbTxMetadata = buildTxLoop cstrat extraLovelaceStart where certsFinalised = finaliseTxCert (gyBTxEnvProtocolParams env) <$> certs @@ -157,64 +169,68 @@ buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub sig buildTxLoop :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) buildTxLoop stepStrat n - -- Stop trying with RandomImprove if extra lovelace has hit the pre-determined ceiling. - | stepStrat /= GYLargestFirstMultiAsset && n >= randImproveExtraLovelaceCeil = buildTxLoop GYLargestFirstMultiAsset n - | otherwise = do - res <- f stepStrat n - case res of - {- These errors generally indicate the input selection process selected less ada - than necessary. Try again with double the extra lovelace amount -} - Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceNegative{}) -> buildTxLoop stepStrat (n * 2) - Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceTooSmall{}) -> buildTxLoop stepStrat (n * 2) - -- @RandomImprove@ may result into many change outputs, where their minimum ada requirements might be unsatisfiable with available ada. - Left (GYBuildTxBalancingError err@(GYBalancingErrorChangeShortFall _)) -> retryIfRandomImprove - stepStrat - n - (GYBuildTxBalancingError err) - {- RandomImprove may end up selecting too many inputs to fit in the transaction. - In this case, try with LargestFirst and dial back the extraLovelace param. - -} - Left (GYBuildTxExUnitsTooBig maxUnits currentUnits) -> retryIfRandomImprove - stepStrat - n - (GYBuildTxExUnitsTooBig maxUnits currentUnits) - Left (GYBuildTxSizeTooBig maxPossibleSize currentSize) -> retryIfRandomImprove - stepStrat - n - (GYBuildTxSizeTooBig maxPossibleSize currentSize) - Right x -> pure $ Right x - {- The most common error here would be: - - InsufficientFunds - - Script validation failure - - Tx not within validity range specified timeframe - - No need to try again for these. - -} - other -> pure other + -- Stop trying with RandomImprove if extra lovelace has hit the pre-determined ceiling. + | stepStrat /= GYLargestFirstMultiAsset && n >= randImproveExtraLovelaceCeil = buildTxLoop GYLargestFirstMultiAsset n + | otherwise = do + res <- f stepStrat n + case res of + {- These errors generally indicate the input selection process selected less ada + than necessary. Try again with double the extra lovelace amount -} + Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceNegative {}) -> buildTxLoop stepStrat (n * 2) + Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceTooSmall {}) -> buildTxLoop stepStrat (n * 2) + -- @RandomImprove@ may result into many change outputs, where their minimum ada requirements might be unsatisfiable with available ada. + Left (GYBuildTxBalancingError err@(GYBalancingErrorChangeShortFall _)) -> + retryIfRandomImprove + stepStrat + n + (GYBuildTxBalancingError err) + {- RandomImprove may end up selecting too many inputs to fit in the transaction. + In this case, try with LargestFirst and dial back the extraLovelace param. + -} + Left (GYBuildTxExUnitsTooBig maxUnits currentUnits) -> + retryIfRandomImprove + stepStrat + n + (GYBuildTxExUnitsTooBig maxUnits currentUnits) + Left (GYBuildTxSizeTooBig maxPossibleSize currentSize) -> + retryIfRandomImprove + stepStrat + n + (GYBuildTxSizeTooBig maxPossibleSize currentSize) + Right x -> pure $ Right x + {- The most common error here would be: + - InsufficientFunds + - Script validation failure + - Tx not within validity range specified timeframe + + No need to try again for these. + -} + other -> pure other f :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) f stepStrat pessimisticFee = do - stepRes <- step stepStrat pessimisticFee - pure $ stepRes >>= \(ins, collaterals, outs) -> - finalizeGYBalancedTx - env - GYBalancedTx - { gybtxIns = ins - , gybtxCollaterals = collaterals - , gybtxOuts = outs - , gybtxMint = mmint - , gybtxWdrls = wdrls - , gybtxCerts = certsFinalised - , gybtxInvalidBefore = lb - , gybtxInvalidAfter = ub - , gybtxSigners = signers - , gybtxRefIns = refIns - , gybtxMetadata = mbTxMetadata - } - (length outsOld) + stepRes <- step stepStrat pessimisticFee + pure $ + stepRes >>= \(ins, collaterals, outs) -> + finalizeGYBalancedTx + env + GYBalancedTx + { gybtxIns = ins + , gybtxCollaterals = collaterals + , gybtxOuts = outs + , gybtxMint = mmint + , gybtxWdrls = wdrls + , gybtxCerts = certsFinalised + , gybtxInvalidBefore = lb + , gybtxInvalidAfter = ub + , gybtxSigners = signers + , gybtxRefIns = refIns + , gybtxMetadata = mbTxMetadata + } + (length outsOld) retryIfRandomImprove GYRandomImproveMultiAsset n _ = buildTxLoop GYLargestFirstMultiAsset (if n == extraLovelaceStart then extraLovelaceStart else n `div` 2) - retryIfRandomImprove _ _ err = pure $ Left err + retryIfRandomImprove _ _ err = pure $ Left err ------------------------------------------------------------------------------- -- Primary balancing logic @@ -227,140 +243,158 @@ is too small, there will not be enough ada to pay for the final fees + min depos the tx with 'finalizeGYBalancedTx'. If such is the case, 'balanceTxStep' should be called again with a higher 'extraLovelace' amount. -} -balanceTxStep :: (HasCallStack, MonadRandom m) - => GYBuildTxEnv - -> Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) -- ^ minting - -> [GYTxWdrl v] -- ^ withdrawals - -> [GYTxCert' v] -- ^ certificates - -> [GYTxInDetailed v] -- ^ transaction inputs - -> [GYTxOut v] -- ^ transaction outputs - -> GYCoinSelectionStrategy -- ^ Coin selection strategy to use - -> Natural -- ^ extra lovelace to look for on top of output value - -> m (Either GYBalancingError ([GYTxInDetailed v], GYUTxOs, [GYTxOut v])) +balanceTxStep :: + (HasCallStack, MonadRandom m) => + GYBuildTxEnv -> + -- | minting + Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) -> + -- | withdrawals + [GYTxWdrl v] -> + -- | certificates + [GYTxCert' v] -> + -- | transaction inputs + [GYTxInDetailed v] -> + -- | transaction outputs + [GYTxOut v] -> + -- | Coin selection strategy to use + GYCoinSelectionStrategy -> + -- | extra lovelace to look for on top of output value + Natural -> + m (Either GYBalancingError ([GYTxInDetailed v], GYUTxOs, [GYTxOut v])) balanceTxStep - GYBuildTxEnv - { gyBTxEnvProtocolParams = pp - , gyBTxEnvOwnUtxos = ownUtxos - , gyBTxEnvChangeAddr = changeAddr - , gyBTxEnvCollateral = collateral - } - mmint - wdrls - certs - ins - outs - cstrat - = let adjustedOuts = map (adjustTxOut (minimumUTxO pp)) outs - valueMint = maybe mempty fst mmint - needsCollateral = valueMint /= mempty || any (isScriptWitness . gyTxInWitness . gyTxInDet) ins || any (isCertScriptWitness . gyTxCertWitness') certs || any (isWdrlScriptWitness . gyTxWdrlWitness) wdrls - (stakeCredDeregsAmt :: Natural, stakeCredRegsAmt :: Natural) = foldl' (\acc@(!accDeregsAmt, !accRegsAmt) (gyTxCertCertificate' -> cert) -> case cert of - GYStakeAddressDeregistrationCertificate amt _ -> (accDeregsAmt + amt, accRegsAmt) - GYStakeAddressRegistrationCertificate amt _ -> (accDeregsAmt, accRegsAmt + amt) - GYStakeAddressRegistrationDelegationCertificate amt _ _ -> (accDeregsAmt, accRegsAmt + amt) - _ -> acc) (0, 0) certs - -- Extra ada is received from withdrawals and stake credential deregistration. - adaSource = - let wdrlsAda = getSum $ foldMap' (coerce . gyTxWdrlAmount) wdrls - in wdrlsAda + stakeCredDeregsAmt - -- Ada lost due to stake credential registration. - adaSink = stakeCredRegsAmt - collaterals - | needsCollateral = utxosFromUTxO collateral - | otherwise = mempty - in \extraLovelace -> runExceptT $ do - for_ adjustedOuts $ \txOut -> - unless (valueNonNegative $ gyTxOutValue txOut) - . throwE $ GYBalancingErrorNonPositiveTxOut txOut - (addIns, changeOuts) <- selectInputs - GYCoinSelectionEnv - { existingInputs = ins - , requiredOutputs = (gyTxOutAddress &&& gyTxOutValue) <$> adjustedOuts - , mintValue = valueMint - , changeAddr = changeAddr - , ownUtxos = ownUtxos - , extraLovelace = extraLovelace - , minimumUTxOF = - fromInteger - . flip valueAssetClass GYLovelace - . gyTxOutValue - . adjustTxOut (minimumUTxO pp) - , maxValueSize = pp ^. Ledger.ppMaxValSizeL - , adaSource = adaSource - , adaSink = adaSink - } - cstrat - pure (ins ++ addIns, collaterals, adjustedOuts ++ changeOuts) - where - isScriptWitness GYTxInWitnessKey = False - isScriptWitness GYTxInWitnessScript{} = True - isScriptWitness GYTxInWitnessSimpleScript{} = False -- Simple (native) scripts don't require collateral. - isCertScriptWitness (Just GYTxCertWitnessScript{}) = True - isCertScriptWitness _ = False - isWdrlScriptWitness GYTxWdrlWitnessScript{} = True - isWdrlScriptWitness _ = False + GYBuildTxEnv + { gyBTxEnvProtocolParams = pp + , gyBTxEnvOwnUtxos = ownUtxos + , gyBTxEnvChangeAddr = changeAddr + , gyBTxEnvCollateral = collateral + } + mmint + wdrls + certs + ins + outs + cstrat = + let adjustedOuts = map (adjustTxOut (minimumUTxO pp)) outs + valueMint = maybe mempty fst mmint + needsCollateral = valueMint /= mempty || any (isScriptWitness . gyTxInWitness . gyTxInDet) ins || any (isCertScriptWitness . gyTxCertWitness') certs || any (isWdrlScriptWitness . gyTxWdrlWitness) wdrls + (stakeCredDeregsAmt :: Natural, stakeCredRegsAmt :: Natural) = + foldl' + ( \acc@(!accDeregsAmt, !accRegsAmt) (gyTxCertCertificate' -> cert) -> case cert of + GYStakeAddressDeregistrationCertificate amt _ -> (accDeregsAmt + amt, accRegsAmt) + GYStakeAddressRegistrationCertificate amt _ -> (accDeregsAmt, accRegsAmt + amt) + GYStakeAddressRegistrationDelegationCertificate amt _ _ -> (accDeregsAmt, accRegsAmt + amt) + _ -> acc + ) + (0, 0) + certs + -- Extra ada is received from withdrawals and stake credential deregistration. + adaSource = + let wdrlsAda = getSum $ foldMap' (coerce . gyTxWdrlAmount) wdrls + in wdrlsAda + stakeCredDeregsAmt + -- Ada lost due to stake credential registration. + adaSink = stakeCredRegsAmt + collaterals + | needsCollateral = utxosFromUTxO collateral + | otherwise = mempty + in \extraLovelace -> runExceptT $ do + for_ adjustedOuts $ \txOut -> + unless (valueNonNegative $ gyTxOutValue txOut) + . throwE + $ GYBalancingErrorNonPositiveTxOut txOut + (addIns, changeOuts) <- + selectInputs + GYCoinSelectionEnv + { existingInputs = ins + , requiredOutputs = (gyTxOutAddress &&& gyTxOutValue) <$> adjustedOuts + , mintValue = valueMint + , changeAddr = changeAddr + , ownUtxos = ownUtxos + , extraLovelace = extraLovelace + , minimumUTxOF = + fromInteger + . flip valueAssetClass GYLovelace + . gyTxOutValue + . adjustTxOut (minimumUTxO pp) + , maxValueSize = pp ^. Ledger.ppMaxValSizeL + , adaSource = adaSource + , adaSink = adaSink + } + cstrat + pure (ins ++ addIns, collaterals, adjustedOuts ++ changeOuts) + where + isScriptWitness GYTxInWitnessKey = False + isScriptWitness GYTxInWitnessScript {} = True + isScriptWitness GYTxInWitnessSimpleScript {} = False -- Simple (native) scripts don't require collateral. + isCertScriptWitness (Just GYTxCertWitnessScript {}) = True + isCertScriptWitness _ = False + isWdrlScriptWitness GYTxWdrlWitnessScript {} = True + isWdrlScriptWitness _ = False retColSup :: Api.BabbageEraOnwards ApiEra retColSup = Api.BabbageEraOnwardsConway finalizeGYBalancedTx :: GYBuildTxEnv -> GYBalancedTx v -> Int -> Either GYBuildTxError GYTxBody finalizeGYBalancedTx - GYBuildTxEnv - { gyBTxEnvSystemStart = ss - , gyBTxEnvEraHistory = eh - , gyBTxEnvProtocolParams = pp - , gyBTxEnvPools = ps - , gyBTxEnvChangeAddr = changeAddr - } - GYBalancedTx - { gybtxIns = ins - , gybtxCollaterals = collaterals - , gybtxOuts = outs - , gybtxMint = mmint - , gybtxWdrls = wdrls - , gybtxCerts = certs - , gybtxInvalidBefore = lb - , gybtxInvalidAfter = ub - , gybtxSigners = signers - , gybtxRefIns = utxosRefInputs - , gybtxMetadata = mbTxMetadata - } - = makeTransactionBodyAutoBalanceWrapper - collaterals - ss - eh - pp - ps - (utxosToApi utxos) - body - changeAddr - unregisteredStakeCredsMap - estimateKeyWitnesses - where - -- Over-estimate the number of key witnesses required for the transaction. - -- We do not provide support for byron key witnesses in our estimate as @Api.makeTransactionBodyAutoBalance@ does not consider them, i.e., count of key witnesses returned here are considered as shelley key witnesses by cardano api. - estimateKeyWitnesses :: Word = fromIntegral $ countUnique $ - mapMaybe (extractPaymentPkhFromAddress . utxoAddress) (utxosToList collaterals) - <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxWdrlWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferSCByKey sc]] - <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxCertWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferSCByKey sc]] - <> estimateKeyWitnessesFromInputs ins - <> Set.toList signers - where - extractPaymentPkhFromAddress gyaddr = addressToPaymentCredential gyaddr >>= \case - GYPaymentCredentialByKey pkh -> Just $ toPubKeyHash pkh - GYPaymentCredentialByScript _ -> Nothing - - preferSCByKey (GYStakeCredentialByKey pkh) = Just $ toPubKeyHash pkh - preferSCByKey _otherwise = Nothing - - countUnique :: Ord a => [a] -> Int - countUnique = Set.size . Set.fromList - - estimateKeyWitnessesFromInputs txInDets = - -- Count key witnesses. - [apkh | txInDet@GYTxInDetailed {gyTxInDet = GYTxIn {gyTxInWitness = GYTxInWitnessKey}} <- txInDets, let gyaddr = gyTxInDetAddress txInDet, Just apkh <- [extractPaymentPkhFromAddress gyaddr]] - ++ - -- Estimate key witnesses required by native scripts. - map toPubKeyHash (Set.toList $ foldl' estimateKeyWitnessesFromNativeScripts mempty txInDets) + GYBuildTxEnv + { gyBTxEnvSystemStart = ss + , gyBTxEnvEraHistory = eh + , gyBTxEnvProtocolParams = pp + , gyBTxEnvPools = ps + , gyBTxEnvChangeAddr = changeAddr + } + GYBalancedTx + { gybtxIns = ins + , gybtxCollaterals = collaterals + , gybtxOuts = outs + , gybtxMint = mmint + , gybtxWdrls = wdrls + , gybtxCerts = certs + , gybtxInvalidBefore = lb + , gybtxInvalidAfter = ub + , gybtxSigners = signers + , gybtxRefIns = utxosRefInputs + , gybtxMetadata = mbTxMetadata + } = + makeTransactionBodyAutoBalanceWrapper + collaterals + ss + eh + pp + ps + (utxosToApi utxos) + body + changeAddr + unregisteredStakeCredsMap + estimateKeyWitnesses + where + -- Over-estimate the number of key witnesses required for the transaction. + -- We do not provide support for byron key witnesses in our estimate as @Api.makeTransactionBodyAutoBalance@ does not consider them, i.e., count of key witnesses returned here are considered as shelley key witnesses by cardano api. + estimateKeyWitnesses :: Word = + fromIntegral $ + countUnique $ + mapMaybe (extractPaymentPkhFromAddress . utxoAddress) (utxosToList collaterals) + <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxWdrlWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferSCByKey sc]] + <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxCertWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferSCByKey sc]] + <> estimateKeyWitnessesFromInputs ins + <> Set.toList signers + where + extractPaymentPkhFromAddress gyaddr = + addressToPaymentCredential gyaddr >>= \case + GYPaymentCredentialByKey pkh -> Just $ toPubKeyHash pkh + GYPaymentCredentialByScript _ -> Nothing + + preferSCByKey (GYStakeCredentialByKey pkh) = Just $ toPubKeyHash pkh + preferSCByKey _otherwise = Nothing + + countUnique :: (Ord a) => [a] -> Int + countUnique = Set.size . Set.fromList + + estimateKeyWitnessesFromInputs txInDets = + -- Count key witnesses. + [apkh | txInDet@GYTxInDetailed {gyTxInDet = GYTxIn {gyTxInWitness = GYTxInWitnessKey}} <- txInDets, let gyaddr = gyTxInDetAddress txInDet, Just apkh <- [extractPaymentPkhFromAddress gyaddr]] + ++ + -- Estimate key witnesses required by native scripts. + map toPubKeyHash (Set.toList $ foldl' estimateKeyWitnessesFromNativeScripts mempty txInDets) where estimateKeyWitnessesFromNativeScripts acc (gyTxInWitness . gyTxInDet -> GYTxInWitnessSimpleScript gyInSS) = case gyInSS of @@ -368,160 +402,169 @@ finalizeGYBalancedTx GYInReferenceSimpleScript _ s -> getTotalKeysInSimpleScript s <> acc estimateKeyWitnessesFromNativeScripts acc _ = acc - inRefs :: Api.TxInsReference Api.BuildTx ApiEra - inRefs = case inRefs' of + inRefs :: Api.TxInsReference Api.BuildTx ApiEra + inRefs = case inRefs' of [] -> Api.TxInsReferenceNone - _ -> Api.TxInsReference Api.BabbageEraOnwardsConway inRefs' + _ -> Api.TxInsReference Api.BabbageEraOnwardsConway inRefs' - inRefs' :: [Api.TxIn] - inRefs' = [ txOutRefToApi r | r <- utxosRefs utxosRefInputs ] + inRefs' :: [Api.TxIn] + inRefs' = [txOutRefToApi r | r <- utxosRefs utxosRefInputs] - -- utxos for inputs - utxosIn :: GYUTxOs - utxosIn = utxosFromList $ utxoFromTxInDetailed <$> ins + -- utxos for inputs + utxosIn :: GYUTxOs + utxosIn = utxosFromList $ utxoFromTxInDetailed <$> ins - -- Map to lookup information for various utxos. - utxos :: GYUTxOs - utxos = utxosIn <> utxosRefInputs <> collaterals + -- Map to lookup information for various utxos. + utxos :: GYUTxOs + utxos = utxosIn <> utxosRefInputs <> collaterals - outs' :: [Api.S.TxOut Api.S.CtxTx ApiEra] - outs' = txOutToApi <$> outs + outs' :: [Api.S.TxOut Api.S.CtxTx ApiEra] + outs' = txOutToApi <$> outs - ins' :: [(Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn ApiEra))] - ins' = [ txInToApi (isInlineDatum $ gyTxInDetDatum i) (gyTxInDet i) | i <- ins ] + ins' :: [(Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn ApiEra))] + ins' = [txInToApi (isInlineDatum $ gyTxInDetDatum i) (gyTxInDet i) | i <- ins] - collaterals' :: Api.TxInsCollateral ApiEra - collaterals' = case utxosRefs collaterals of - [] -> Api.TxInsCollateralNone + collaterals' :: Api.TxInsCollateral ApiEra + collaterals' = case utxosRefs collaterals of + [] -> Api.TxInsCollateralNone orefs -> Api.TxInsCollateral Api.AlonzoEraOnwardsConway $ txOutRefToApi <$> orefs - -- will be filled by makeTransactionBodyAutoBalance - fee :: Api.TxFee ApiEra - fee = Api.TxFeeExplicit Api.ShelleyBasedEraConway $ Ledger.Coin 0 + -- will be filled by makeTransactionBodyAutoBalance + fee :: Api.TxFee ApiEra + fee = Api.TxFeeExplicit Api.ShelleyBasedEraConway $ Ledger.Coin 0 - lb' :: Api.TxValidityLowerBound ApiEra - lb' = maybe - Api.TxValidityNoLowerBound - (Api.TxValidityLowerBound Api.AllegraEraOnwardsConway . slotToApi) - lb + lb' :: Api.TxValidityLowerBound ApiEra + lb' = + maybe + Api.TxValidityNoLowerBound + (Api.TxValidityLowerBound Api.AllegraEraOnwardsConway . slotToApi) + lb - ub' :: Api.TxValidityUpperBound ApiEra - ub' = Api.TxValidityUpperBound Api.ShelleyBasedEraConway $ slotToApi <$> ub + ub' :: Api.TxValidityUpperBound ApiEra + ub' = Api.TxValidityUpperBound Api.ShelleyBasedEraConway $ slotToApi <$> ub - extra :: Api.TxExtraKeyWitnesses ApiEra - extra = case toList signers of - [] -> Api.TxExtraKeyWitnessesNone + extra :: Api.TxExtraKeyWitnesses ApiEra + extra = case toList signers of + [] -> Api.TxExtraKeyWitnessesNone pkhs -> Api.TxExtraKeyWitnesses Api.AlonzoEraOnwardsConway $ pubKeyHashToApi <$> pkhs - mint :: Api.TxMintValue Api.BuildTx ApiEra - mint = case mmint of - Nothing -> Api.TxMintNone - Just (v, xs) -> Api.TxMintValue Api.MaryEraOnwardsConway (valueToApi v) $ Api.BuildTxWith $ Map.fromList - [ ( mintingPolicyApiIdFromWitness p - , gyMintingScriptWitnessToApiPlutusSW p + mint :: Api.TxMintValue Api.BuildTx ApiEra + mint = case mmint of + Nothing -> Api.TxMintNone + Just (v, xs) -> + Api.TxMintValue Api.MaryEraOnwardsConway (valueToApi v) $ + Api.BuildTxWith $ + Map.fromList + [ ( mintingPolicyApiIdFromWitness p + , gyMintingScriptWitnessToApiPlutusSW + p (redeemerToApi r) (Api.ExecutionUnits 0 0) - ) - | (p, r) <- xs - ] - - -- Putting `TxTotalCollateralNone` & `TxReturnCollateralNone` would have them appropriately calculated by `makeTransactionBodyAutoBalance` but then return collateral it generates is only for ada. To support multi-asset collateral input we therefore calculate correct values ourselves and put appropriate entries here to have `makeTransactionBodyAutoBalance` calculate appropriate overestimated fees. - (dummyTotCol :: Api.TxTotalCollateral ApiEra, dummyRetCol :: Api.TxReturnCollateral Api.CtxTx ApiEra) = - if mempty == collaterals then - (Api.TxTotalCollateralNone, Api.TxReturnCollateralNone) - else - ( - -- Total collateral must be <= lovelaces available in collateral inputs. - Api.TxTotalCollateral retColSup (Ledger.Coin $ fst $ valueSplitAda collateralTotalValue) - -- Return collateral must be <= what is in collateral inputs. - , Api.TxReturnCollateral retColSup $ txOutToApi $ GYTxOut changeAddr collateralTotalValue Nothing Nothing - ) - where - collateralTotalValue :: GYValue - collateralTotalValue = foldMapUTxOs utxoValue collaterals - - txMetadata :: Api.TxMetadataInEra ApiEra - txMetadata = maybe Api.TxMetadataNone toMetaInEra mbTxMetadata - where - toMetaInEra :: GYTxMetadata -> Api.TxMetadataInEra ApiEra - toMetaInEra gymd = let md = txMetadataToApi gymd in - if md == mempty then Api.TxMetadataNone else Api.TxMetadataInEra Api.ShelleyBasedEraConway md - - wdrls' :: Api.TxWithdrawals Api.BuildTx ApiEra - wdrls' = if wdrls == mempty then Api.TxWithdrawalsNone else Api.TxWithdrawals Api.ShelleyBasedEraConway $ map txWdrlToApi wdrls - - certs' = - if certs == mempty - then Api.TxCertificatesNone - else - let apiCertsFromGY = - foldl' - (\(accCerts, accWits) cert -> - let (apiCert, mapiWit) = txCertToApi cert - apiWit = maybe Map.empty (uncurry Map.singleton) mapiWit - in (apiCert : accCerts, accWits <> apiWit) - ) (mempty, mempty) certs - in Api.TxCertificates Api.ShelleyBasedEraConway (reverse $ fst apiCertsFromGY) $ Api.BuildTxWith (snd apiCertsFromGY) - - unregisteredStakeCredsMap = Map.fromList [ (stakeCredentialToApi sc, fromIntegral amt) | GYStakeAddressDeregistrationCertificate amt sc <- map gyTxCertCertificate' certs] - - body :: Api.TxBodyContent Api.BuildTx ApiEra - body = - Api.TxBodyContent { - Api.txIns = ins', - Api.txInsCollateral = collaterals', - Api.txInsReference = inRefs, - Api.txOuts = outs', - Api.txTotalCollateral = dummyTotCol, - Api.txReturnCollateral = dummyRetCol, - Api.txFee = fee, - Api.txValidityLowerBound = lb', - Api.txValidityUpperBound = ub', - Api.txMetadata = txMetadata, - Api.txAuxScripts = Api.TxAuxScriptsNone, - Api.txExtraKeyWits = extra, - Api.txProtocolParams = Api.BuildTxWith $ Just $ Api.S.LedgerProtocolParameters pp, - Api.txWithdrawals = wdrls', - Api.txCertificates = certs', - Api.txUpdateProposal = Api.TxUpdateProposalNone, - Api.txMintValue = mint, - Api.txScriptValidity = Api.TxScriptValidityNone, - Api.txProposalProcedures = Nothing, - Api.txVotingProcedures = Nothing, - Api.txCurrentTreasuryValue = Nothing, -- FIXME:? - Api.txTreasuryDonation = Nothing - } + ) + | (p, r) <- xs + ] + + -- Putting `TxTotalCollateralNone` & `TxReturnCollateralNone` would have them appropriately calculated by `makeTransactionBodyAutoBalance` but then return collateral it generates is only for ada. To support multi-asset collateral input we therefore calculate correct values ourselves and put appropriate entries here to have `makeTransactionBodyAutoBalance` calculate appropriate overestimated fees. + (dummyTotCol :: Api.TxTotalCollateral ApiEra, dummyRetCol :: Api.TxReturnCollateral Api.CtxTx ApiEra) = + if mempty == collaterals + then + (Api.TxTotalCollateralNone, Api.TxReturnCollateralNone) + else + ( -- Total collateral must be <= lovelaces available in collateral inputs. + Api.TxTotalCollateral retColSup (Ledger.Coin $ fst $ valueSplitAda collateralTotalValue) + , -- Return collateral must be <= what is in collateral inputs. + Api.TxReturnCollateral retColSup $ txOutToApi $ GYTxOut changeAddr collateralTotalValue Nothing Nothing + ) + where + collateralTotalValue :: GYValue + collateralTotalValue = foldMapUTxOs utxoValue collaterals + + txMetadata :: Api.TxMetadataInEra ApiEra + txMetadata = maybe Api.TxMetadataNone toMetaInEra mbTxMetadata + where + toMetaInEra :: GYTxMetadata -> Api.TxMetadataInEra ApiEra + toMetaInEra gymd = + let md = txMetadataToApi gymd + in if md == mempty then Api.TxMetadataNone else Api.TxMetadataInEra Api.ShelleyBasedEraConway md + + wdrls' :: Api.TxWithdrawals Api.BuildTx ApiEra + wdrls' = if wdrls == mempty then Api.TxWithdrawalsNone else Api.TxWithdrawals Api.ShelleyBasedEraConway $ map txWdrlToApi wdrls + + certs' = + if certs == mempty + then Api.TxCertificatesNone + else + let apiCertsFromGY = + foldl' + ( \(accCerts, accWits) cert -> + let (apiCert, mapiWit) = txCertToApi cert + apiWit = maybe Map.empty (uncurry Map.singleton) mapiWit + in (apiCert : accCerts, accWits <> apiWit) + ) + (mempty, mempty) + certs + in Api.TxCertificates Api.ShelleyBasedEraConway (reverse $ fst apiCertsFromGY) $ Api.BuildTxWith (snd apiCertsFromGY) + + unregisteredStakeCredsMap = Map.fromList [(stakeCredentialToApi sc, fromIntegral amt) | GYStakeAddressDeregistrationCertificate amt sc <- map gyTxCertCertificate' certs] + + body :: Api.TxBodyContent Api.BuildTx ApiEra + body = + Api.TxBodyContent + { Api.txIns = ins' + , Api.txInsCollateral = collaterals' + , Api.txInsReference = inRefs + , Api.txOuts = outs' + , Api.txTotalCollateral = dummyTotCol + , Api.txReturnCollateral = dummyRetCol + , Api.txFee = fee + , Api.txValidityLowerBound = lb' + , Api.txValidityUpperBound = ub' + , Api.txMetadata = txMetadata + , Api.txAuxScripts = Api.TxAuxScriptsNone + , Api.txExtraKeyWits = extra + , Api.txProtocolParams = Api.BuildTxWith $ Just $ Api.S.LedgerProtocolParameters pp + , Api.txWithdrawals = wdrls' + , Api.txCertificates = certs' + , Api.txUpdateProposal = Api.TxUpdateProposalNone + , Api.txMintValue = mint + , Api.txScriptValidity = Api.TxScriptValidityNone + , Api.txProposalProcedures = Nothing + , Api.txVotingProcedures = Nothing + , Api.txCurrentTreasuryValue = Nothing -- FIXME:? + , Api.txTreasuryDonation = Nothing + } {- | Wraps around 'Api.makeTransactionBodyAutoBalance' just to verify the final ex units and tx size are within limits. If not checked, the returned txbody may fail during submission. -} -makeTransactionBodyAutoBalanceWrapper :: GYUTxOs - -> SystemStart - -> Api.S.EraHistory - -> ApiProtocolParameters - -> Set Api.S.PoolId - -> Api.S.UTxO ApiEra - -> Api.S.TxBodyContent Api.S.BuildTx ApiEra - -> GYAddress - -> Map.Map Api.StakeCredential Ledger.Coin - -> Word - -> Int - -> Either GYBuildTxError GYTxBody +makeTransactionBodyAutoBalanceWrapper :: + GYUTxOs -> + SystemStart -> + Api.S.EraHistory -> + ApiProtocolParameters -> + Set Api.S.PoolId -> + Api.S.UTxO ApiEra -> + Api.S.TxBodyContent Api.S.BuildTx ApiEra -> + GYAddress -> + Map.Map Api.StakeCredential Ledger.Coin -> + Word -> + Int -> + Either GYBuildTxError GYTxBody makeTransactionBodyAutoBalanceWrapper collaterals ss eh pp _ps utxos body changeAddr stakeDelegDeposits nkeys numSkeletonOuts = do - let poolids = Set.empty -- TODO: This denotes the set of registered stake pools, that are being unregistered in this transaction. - - let Ledger.ExUnits - { exUnitsSteps = maxSteps - , exUnitsMem = maxMemory - } = pp ^. Ledger.ppMaxTxExUnitsL - let maxTxSize = fromIntegral $ pp ^. Ledger.ppMaxTxSizeL - changeAddrApi :: Api.S.AddressInEra ApiEra = addressToApi' changeAddr - drepDelegDeposits = mempty -- TODO: - - -- First we obtain the calculated fees to correct for our collaterals. - bodyBeforeCollUpdate@(Api.BalancedTxBody _ _ _ (Ledger.Coin feeOld)) <- - first GYBuildTxBodyErrorAutoBalance $ Api.makeTransactionBodyAutoBalance + let poolids = Set.empty -- TODO: This denotes the set of registered stake pools, that are being unregistered in this transaction. + let Ledger.ExUnits + { exUnitsSteps = maxSteps + , exUnitsMem = maxMemory + } = pp ^. Ledger.ppMaxTxExUnitsL + let maxTxSize = fromIntegral $ pp ^. Ledger.ppMaxTxSizeL + changeAddrApi :: Api.S.AddressInEra ApiEra = addressToApi' changeAddr + drepDelegDeposits = mempty -- TODO: + + -- First we obtain the calculated fees to correct for our collaterals. + bodyBeforeCollUpdate@(Api.BalancedTxBody _ _ _ (Ledger.Coin feeOld)) <- + first GYBuildTxBodyErrorAutoBalance $ + Api.makeTransactionBodyAutoBalance Api.ShelleyBasedEraConway ss (Api.toLedgerEpochInfo eh) @@ -534,82 +577,84 @@ makeTransactionBodyAutoBalanceWrapper collaterals ss eh pp _ps utxos body change changeAddrApi (Just nkeys) - -- We should call `makeTransactionBodyAutoBalance` again with updated values of collaterals so as to get slightly lower fee estimate. - Api.BalancedTxBody txBodyContent txBody extraOut _ <- if collaterals == mempty then return bodyBeforeCollUpdate else - - let - - collateralTotalValue :: GYValue = foldMapUTxOs utxoValue collaterals - collateralTotalLovelace :: Integer = fst $ valueSplitAda collateralTotalValue - balanceNeeded :: Integer = ceiling $ (feeOld * toInteger (pp ^. ppCollateralPercentageL)) % 100 - - in do - - (txColl, collRet) <- - if collateralTotalLovelace >= balanceNeeded then return - ( - Api.TxTotalCollateral retColSup (Ledger.Coin balanceNeeded) - , Api.TxReturnCollateral retColSup $ txOutToApi $ GYTxOut changeAddr (collateralTotalValue `valueMinus` valueFromLovelace balanceNeeded) Nothing Nothing - - ) - else Left $ GYBuildTxCollateralShortFall (fromInteger balanceNeeded) (fromInteger collateralTotalLovelace) - - -- In this case `makeTransactionBodyAutoBalance` doesn't return - -- an error but instead returns `(Api.TxTotalCollateralNone, Api.TxReturnCollateralNone)` - - first GYBuildTxBodyErrorAutoBalance $ Api.makeTransactionBodyAutoBalance - Api.ShelleyBasedEraConway - ss - (Api.toLedgerEpochInfo eh) - (Api.LedgerProtocolParameters pp) - poolids - stakeDelegDeposits - drepDelegDeposits - utxos - body {Api.txTotalCollateral = txColl, Api.txReturnCollateral = collRet} - changeAddrApi - (Just nkeys) - - let Api.S.ShelleyTx _ ltx = Api.Tx txBody [] - -- This sums up the ExUnits for all embedded Plutus Scripts anywhere in the transaction: - AlonzoScripts.ExUnits - { AlonzoScripts.exUnitsSteps = steps - , AlonzoScripts.exUnitsMem = mem - } = AlonzoTx.totExUnits ltx - txSize :: Natural = - let - -- This low level code is taken verbatim from here: https://github.com/IntersectMBO/cardano-ledger/blob/6db84a7b77e19af58feb2f45dfc50aa70435967b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs#L475-L494, as this is what is referred by @cardano-api@ under the hood. - -- This does not take into account the bootstrap (byron) witnesses. - version = eraProtVerLow @ShelleyBasedConwayEra - sigSize = fromIntegral $ sizeSigDSIGN (Proxy @(DSIGN (EraCrypto ShelleyBasedConwayEra))) - dummySig = - fromRight - (error "corrupt dummy signature") - ( CBOR.decodeFullDecoder - version - "dummy signature" - CBOR.decodeSignedDSIGN - (CBOR.serialize version $ LBS.replicate sigSize 0) - ) - vkeySize = fromIntegral $ sizeVerKeyDSIGN (Proxy @(DSIGN (EraCrypto ShelleyBasedConwayEra))) - dummyVKey w = - let padding = LBS.replicate paddingSize 0 - paddingSize = vkeySize - LBS.length sw - sw = CBOR.serialize version w - keyBytes = CBOR.serialize version $ padding <> sw - in fromRight (error "corrupt dummy vkey") (CBOR.decodeFull version keyBytes) - in fromInteger $ view sizeTxF $ Shelley.addKeyWitnesses ltx (Set.fromList [WitVKey (dummyVKey x) dummySig | x <- [1 .. nkeys]]) - -- See: Cardano.Ledger.Alonzo.Rules.validateExUnitsTooBigUTxO - unless (steps <= maxSteps && mem <= maxMemory) $ - Left $ GYBuildTxExUnitsTooBig (maxSteps, maxMemory) (steps, mem) - -- See: Cardano.Ledger.Shelley.Rules.validateMaxTxSizeUTxO - unless (txSize <= maxTxSize) $ - Left (GYBuildTxSizeTooBig maxTxSize txSize) - - collapsedBody <- first GYBuildTxCollapseExtraOutError $ collapseExtraOut extraOut txBodyContent txBody numSkeletonOuts - - first GYBuildTxCborSimplificationError $ simplifyGYTxBodyCbor $ txBodyFromApi collapsedBody - + -- We should call `makeTransactionBodyAutoBalance` again with updated values of collaterals so as to get slightly lower fee estimate. + Api.BalancedTxBody txBodyContent txBody extraOut _ <- + if collaterals == mempty + then return bodyBeforeCollUpdate + else + let + collateralTotalValue :: GYValue = foldMapUTxOs utxoValue collaterals + collateralTotalLovelace :: Integer = fst $ valueSplitAda collateralTotalValue + balanceNeeded :: Integer = ceiling $ (feeOld * toInteger (pp ^. ppCollateralPercentageL)) % 100 + in + do + (txColl, collRet) <- + if collateralTotalLovelace >= balanceNeeded + then + return + ( Api.TxTotalCollateral retColSup (Ledger.Coin balanceNeeded) + , Api.TxReturnCollateral retColSup $ txOutToApi $ GYTxOut changeAddr (collateralTotalValue `valueMinus` valueFromLovelace balanceNeeded) Nothing Nothing + ) + else Left $ GYBuildTxCollateralShortFall (fromInteger balanceNeeded) (fromInteger collateralTotalLovelace) + + -- In this case `makeTransactionBodyAutoBalance` doesn't return + -- an error but instead returns `(Api.TxTotalCollateralNone, Api.TxReturnCollateralNone)` + + first GYBuildTxBodyErrorAutoBalance $ + Api.makeTransactionBodyAutoBalance + Api.ShelleyBasedEraConway + ss + (Api.toLedgerEpochInfo eh) + (Api.LedgerProtocolParameters pp) + poolids + stakeDelegDeposits + drepDelegDeposits + utxos + body {Api.txTotalCollateral = txColl, Api.txReturnCollateral = collRet} + changeAddrApi + (Just nkeys) + + let Api.S.ShelleyTx _ ltx = Api.Tx txBody [] + -- This sums up the ExUnits for all embedded Plutus Scripts anywhere in the transaction: + AlonzoScripts.ExUnits + { AlonzoScripts.exUnitsSteps = steps + , AlonzoScripts.exUnitsMem = mem + } = AlonzoTx.totExUnits ltx + txSize :: Natural = + let + -- This low level code is taken verbatim from here: https://github.com/IntersectMBO/cardano-ledger/blob/6db84a7b77e19af58feb2f45dfc50aa70435967b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs#L475-L494, as this is what is referred by @cardano-api@ under the hood. + -- This does not take into account the bootstrap (byron) witnesses. + version = eraProtVerLow @ShelleyBasedConwayEra + sigSize = fromIntegral $ sizeSigDSIGN (Proxy @(DSIGN (EraCrypto ShelleyBasedConwayEra))) + dummySig = + fromRight + (error "corrupt dummy signature") + ( CBOR.decodeFullDecoder + version + "dummy signature" + CBOR.decodeSignedDSIGN + (CBOR.serialize version $ LBS.replicate sigSize 0) + ) + vkeySize = fromIntegral $ sizeVerKeyDSIGN (Proxy @(DSIGN (EraCrypto ShelleyBasedConwayEra))) + dummyVKey w = + let padding = LBS.replicate paddingSize 0 + paddingSize = vkeySize - LBS.length sw + sw = CBOR.serialize version w + keyBytes = CBOR.serialize version $ padding <> sw + in fromRight (error "corrupt dummy vkey") (CBOR.decodeFull version keyBytes) + in + fromInteger $ view sizeTxF $ Shelley.addKeyWitnesses ltx (Set.fromList [WitVKey (dummyVKey x) dummySig | x <- [1 .. nkeys]]) + -- See: Cardano.Ledger.Alonzo.Rules.validateExUnitsTooBigUTxO + unless (steps <= maxSteps && mem <= maxMemory) $ + Left $ + GYBuildTxExUnitsTooBig (maxSteps, maxMemory) (steps, mem) + -- See: Cardano.Ledger.Shelley.Rules.validateMaxTxSizeUTxO + unless (txSize <= maxTxSize) $ + Left (GYBuildTxSizeTooBig maxTxSize txSize) + + collapsedBody <- first GYBuildTxCollapseExtraOutError $ collapseExtraOut extraOut txBodyContent txBody numSkeletonOuts + + first GYBuildTxCborSimplificationError $ simplifyGYTxBodyCbor $ txBodyFromApi collapsedBody {- | Collapses the extra out generated in the last step of tx building into another change output (If one exists) @@ -618,37 +663,36 @@ makeTransactionBodyAutoBalanceWrapper collaterals ss eh pp _ps utxos body change the amount of outputs described in the GYSkeleton. It is assumed that these outputs are at the start of the txOuts list. -} -collapseExtraOut - :: Api.TxOut Api.S.CtxTx ApiEra - -- ^ The extra output generated by @makeTransactionBodyAutoBalance@. - -> Api.TxBodyContent Api.S.BuildTx ApiEra - -- ^ The body content generated by @makeTransactionBodyAutoBalance@. - -> Api.TxBody ApiEra - -- ^ The body generated by @makeTransactionBodyAutoBalance@. - -> Int - -- ^ The number of skeleton outputs we don't want to touch. - -> Either Api.S.TxBodyError (Api.TxBody ApiEra) - -- ^ The updated body with the collapsed outputs +collapseExtraOut :: + -- | The extra output generated by @makeTransactionBodyAutoBalance@. + Api.TxOut Api.S.CtxTx ApiEra -> + -- | The body content generated by @makeTransactionBodyAutoBalance@. + Api.TxBodyContent Api.S.BuildTx ApiEra -> + -- | The body generated by @makeTransactionBodyAutoBalance@. + Api.TxBody ApiEra -> + -- | The number of skeleton outputs we don't want to touch. + Int -> + -- | The updated body with the collapsed outputs + Either Api.S.TxBodyError (Api.TxBody ApiEra) collapseExtraOut apiOut@(Api.TxOut _ outVal _ _) bodyContent@Api.TxBodyContent {txOuts} txBody numSkeletonOuts - | Api.txOutValueToLovelace outVal == 0 = pure txBody - | otherwise = - case delete apiOut changeOuts of + | Api.txOutValueToLovelace outVal == 0 = pure txBody + | otherwise = + case delete apiOut changeOuts of [] -> pure txBody ((Api.TxOut sOutAddr sOutVal sOutDat sOutRefScript) : remOuts) -> let - - nOutVal = Api.TxOutValueShelleyBased Api.ShelleyBasedEraConway - $ Api.toLedgerValue Api.MaryEraOnwardsConway - $ foldMap' Api.txOutValueToValue [sOutVal, outVal] + nOutVal = + Api.TxOutValueShelleyBased Api.ShelleyBasedEraConway $ + Api.toLedgerValue Api.MaryEraOnwardsConway $ + foldMap' Api.txOutValueToValue [sOutVal, outVal] -- nOut == new Out == The merging of both apiOut and sOut nOut = Api.TxOut sOutAddr nOutVal sOutDat sOutRefScript -- nOuts == new Outs == The new list of outputs nOuts = skeletonOuts ++ remOuts ++ [nOut] - - in - Api.S.createAndValidateTransactionBody Api.ShelleyBasedEraConway - $ bodyContent { Api.txOuts = nOuts } + in + Api.S.createAndValidateTransactionBody Api.ShelleyBasedEraConway $ + bodyContent {Api.txOuts = nOuts} where (skeletonOuts, changeOuts) = splitAt numSkeletonOuts txOuts diff --git a/src/GeniusYield/Transaction/CBOR.hs b/src/GeniusYield/Transaction/CBOR.hs index 6745c742..39b705ae 100644 --- a/src/GeniusYield/Transaction/CBOR.hs +++ b/src/GeniusYield/Transaction/CBOR.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.Transaction.CBOR Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 @@ -8,34 +8,34 @@ Stability : develop The transaction CBOR as obtained by Cardano API library may not be in format as desired by some hardware/browser wallets. This module attempts to simplify this obtained CBOR to the manner more acceptable. Review this file whenever a hardfork occurs. - -} module GeniusYield.Transaction.CBOR ( - CborSimplificationError (..) - , simplifyGYTxBodyCbor - , simplifyTxCbor - ) where - - -import Codec.CBOR.Read (DeserialiseFailure, - deserialiseFromBytes) -import Codec.CBOR.Term (Term (..), decodeTerm, encodeTerm) -import Codec.CBOR.Write (toStrictByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Base16 as BS16 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as LT (toStrict) - -import GeniusYield.Imports -import GeniusYield.Types.Tx -import GeniusYield.Types.TxBody (GYTxBody, unsignedTx, getTxBody) + CborSimplificationError (..), + simplifyGYTxBodyCbor, + simplifyTxCbor, +) where + +import Codec.CBOR.Read ( + DeserialiseFailure, + deserialiseFromBytes, + ) +import Codec.CBOR.Term (Term (..), decodeTerm, encodeTerm) +import Codec.CBOR.Write (toStrictByteString) +import Data.ByteString qualified as B +import Data.ByteString.Base16 qualified as BS16 +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.Lazy qualified as LT (toStrict) + +import GeniusYield.Imports +import GeniusYield.Types.Tx +import GeniusYield.Types.TxBody (GYTxBody, getTxBody, unsignedTx) -- TODO: Make a log before performing this simplification? -data CborSimplificationError = - TransactionDeserialisationError !DeserialiseFailure +data CborSimplificationError + = TransactionDeserialisationError !DeserialiseFailure | TransactionHasLeftOver !Text | TransactionIsAbsurd !Text | ModifiedTransactionDoesntDeserialise !Text @@ -49,7 +49,6 @@ The modifications done is as follows:- * All indefinite-length items are made definite. * Wherever map occurs, it's keys are sorted as required by [CIP 21](https://cips.cardano.org/cips/cip21/). - -} simplifyTxCbor :: GYTx -> Either CborSimplificationError GYTx simplifyTxCbor tx = do @@ -59,8 +58,8 @@ simplifyTxCbor tx = do case term of TList (txBody : otherFields) -> do let txBody' = simplifyTxBodyCbor txBody - first (ModifiedTransactionDoesntDeserialise . T.pack) $ txFromCBOR $ toStrictByteString $ encodeTerm $ TList (txBody' : otherFields) - _other -> Left $ TransactionIsAbsurd "Transaction is defined as list but received otherwise" + first (ModifiedTransactionDoesntDeserialise . T.pack) $ txFromCBOR $ toStrictByteString $ encodeTerm $ TList (txBody' : otherFields) + _other -> Left $ TransactionIsAbsurd "Transaction is defined as list but received otherwise" {- | Function to modify our CBOR tree according to the given function. If the given function returns `Nothing` it means, it is not applicable to the given `term` and thus we recurse down. Note that the given function (say @f@) must satisfy the following property:- @@ -85,44 +84,42 @@ recursiveTermModification f term = -- | See `simplifyTxCbor`. simplifyTxBodyCbor :: Term -> Term simplifyTxBodyCbor txBody = - -- First, we'll make indefinite-length items, definite. + -- First, we'll make indefinite-length items, definite. let txBodyDefinite = recursiveTermModification makeTermsDefinite txBody -- Second, we'll sort keys in any map. txBodySortedKeys = recursiveTermModification sortMapKeys txBodyDefinite - in txBodySortedKeys - + in txBodySortedKeys where - sortMapKeys :: Term -> Maybe Term sortMapKeys (TMap keyValsToSort) = - if allSameType then - Just $ TMap $ sortBy sortingFunction keyValsToSort - else Nothing + if allSameType + then + Just $ TMap $ sortBy sortingFunction keyValsToSort + else Nothing where sortingFunction :: forall b1 b2. (Term, b1) -> (Term, b2) -> Ordering - sortingFunction (TInt a, _) (TInt b, _) = compare a b + sortingFunction (TInt a, _) (TInt b, _) = compare a b sortingFunction (TInteger a, _) (TInteger b, _) = compare a b - sortingFunction (TBytes a, _) (TBytes b, _) = compare (B.length a) (B.length b) <> compare a b - sortingFunction (TString a, _) (TString b, _) = compare (T.length a) (T.length b) <> compare a b - sortingFunction _ _ = error "absurd - sortingFunction" -- We verify that all keys are of the same appropriate type before calling this function. + sortingFunction (TBytes a, _) (TBytes b, _) = compare (B.length a) (B.length b) <> compare a b + sortingFunction (TString a, _) (TString b, _) = compare (T.length a) (T.length b) <> compare a b + sortingFunction _ _ = error "absurd - sortingFunction" -- We verify that all keys are of the same appropriate type before calling this function. allSameType = any ($ keyValsToSort) [isTInt, isTInteger, isTBytes, isTString] where isTInt = all (\(k, _) -> case k of TInt _ -> True; _ow -> False) isTInteger = all (\(k, _) -> case k of TInteger _ -> True; _ow -> False) isTBytes = all (\(k, _) -> case k of TBytes _ -> True; _ow -> False) isTString = all (\(k, _) -> case k of TString _ -> True; _ow -> False) - sortMapKeys _otherwise = Nothing + sortMapKeys _otherwise = Nothing makeTermsDefinite :: Term -> Maybe Term - makeTermsDefinite (TBytesI b) = Just $ TBytes $ LBS.toStrict b - makeTermsDefinite (TStringI s) = Just $ TString $ LT.toStrict s - makeTermsDefinite (TListI l) = Just $ TList l + makeTermsDefinite (TBytesI b) = Just $ TBytes $ LBS.toStrict b + makeTermsDefinite (TStringI s) = Just $ TString $ LT.toStrict s + makeTermsDefinite (TListI l) = Just $ TList l makeTermsDefinite (TMapI keyVals) = Just $ TMap keyVals - makeTermsDefinite _otherwise = Nothing + makeTermsDefinite _otherwise = Nothing -{- | This `GYTxBody` doesn't represent @transaction_body@ as mentioned in [CDDL](https://github.com/input-output-hk/cardano-ledger/blob/master/eras/babbage/test-suite/cddl-files/babbage.cddl) specification, it's API's internal type to represent transaction without signing key witnesses. However `GYTx` does represent `transaction` as defined in specification. We therefore obtain `GYTx` and work with it. Here we need an invariant, which is if we receive our simplified `GYTx` transaction, then obtaining `GYTxBody` via `getTxBody` and obtaining `GYTx` back via `unsignedTx` should have the same serialisation for the modifications to CBOR encoding we do here. --} +-- | This `GYTxBody` doesn't represent @transaction_body@ as mentioned in [CDDL](https://github.com/input-output-hk/cardano-ledger/blob/master/eras/babbage/test-suite/cddl-files/babbage.cddl) specification, it's API's internal type to represent transaction without signing key witnesses. However `GYTx` does represent `transaction` as defined in specification. We therefore obtain `GYTx` and work with it. Here we need an invariant, which is if we receive our simplified `GYTx` transaction, then obtaining `GYTxBody` via `getTxBody` and obtaining `GYTx` back via `unsignedTx` should have the same serialisation for the modifications to CBOR encoding we do here. simplifyGYTxBodyCbor :: GYTxBody -> Either CborSimplificationError GYTxBody simplifyGYTxBodyCbor txBody = let tx = unsignedTx txBody - in getTxBody <$> simplifyTxCbor tx + in getTxBody <$> simplifyTxCbor tx diff --git a/src/GeniusYield/Transaction/CoinSelection.hs b/src/GeniusYield/Transaction/CoinSelection.hs index 1a145a7a..f22b19aa 100644 --- a/src/GeniusYield/Transaction/CoinSelection.hs +++ b/src/GeniusYield/Transaction/CoinSelection.hs @@ -1,62 +1,66 @@ -{-| +-- To work on this module, module [@Cardano.CoinSelection.Balance@](https://github.com/cardano-foundation/cardano-wallet/blob/master/lib/coin-selection/lib/Cardano/CoinSelection/Balance.hs) should be understood. + +{- | Module : GeniusYield.Transaction.CoinSelection Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} - --- To work on this module, module [@Cardano.CoinSelection.Balance@](https://github.com/cardano-foundation/cardano-wallet/blob/master/lib/coin-selection/lib/Cardano/CoinSelection/Balance.hs) should be understood. - -module GeniusYield.Transaction.CoinSelection - ( GYBalancedTx (..) - , GYTxInDetailed (..) - , GYCoinSelectionEnv (..) - , GYCoinSelectionStrategy (..) - , selectInputs - ) where - -import Control.Monad.Random (MonadRandom) -import Control.Monad.Trans.Except (ExceptT (ExceptT), - except) -import qualified Data.ByteString as BS -import Data.Default (Default (def)) -import qualified Data.Map as Map -import qualified Data.Set as S -import qualified Data.Text as Text -import Data.Text.Class (ToText (toText), - fromText) - -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import qualified Cardano.CoinSelection.Balance as CBalance -import qualified Cardano.CoinSelection.Context as CCoinSelection -import qualified Cardano.Ledger.Binary as CBOR -import Cardano.Ledger.Conway (Conway) - -import qualified Cardano.CoinSelection.Size as CWallet -import qualified Cardano.CoinSelection.UTxOIndex as CWallet -import qualified Cardano.CoinSelection.UTxOSelection as CWallet -import qualified Cardano.Wallet.Primitive.Types.Address as CWallet -import qualified Cardano.Wallet.Primitive.Types.AssetId as CTokenBundle -import qualified Cardano.Wallet.Primitive.Types.AssetName as CWallet -import qualified Cardano.Wallet.Primitive.Types.Coin as CWallet -import qualified Cardano.Wallet.Primitive.Types.Hash as CWallet -import qualified Cardano.Wallet.Primitive.Types.TokenBundle as CTokenBundle -import qualified Cardano.Wallet.Primitive.Types.TokenMap as CWTokenMap -import qualified Cardano.Wallet.Primitive.Types.TokenPolicyId as CWallet -import qualified Cardano.Wallet.Primitive.Types.TokenQuantity as CWallet -import qualified Cardano.Wallet.Primitive.Types.Tx.Constraints as CWallet -import qualified Cardano.Wallet.Primitive.Types.Tx.TxIn as CWallet -import qualified Internal.Cardano.Write.Tx.Balance.CoinSelection as CBalanceInternal (SelectionBalanceError (..), - WalletUTxO (..)) - -import Cardano.Ledger.Conway.Core (eraProtVerHigh) -import GeniusYield.Imports -import GeniusYield.Transaction.Common -import GeniusYield.Types -import GeniusYield.Utils +module GeniusYield.Transaction.CoinSelection ( + GYBalancedTx (..), + GYTxInDetailed (..), + GYCoinSelectionEnv (..), + GYCoinSelectionStrategy (..), + selectInputs, +) where + +import Control.Monad.Random (MonadRandom) +import Control.Monad.Trans.Except ( + ExceptT (ExceptT), + except, + ) +import Data.ByteString qualified as BS +import Data.Default (Default (def)) +import Data.Map qualified as Map +import Data.Set qualified as S +import Data.Text qualified as Text +import Data.Text.Class ( + ToText (toText), + fromText, + ) + +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Cardano.CoinSelection.Balance qualified as CBalance +import Cardano.CoinSelection.Context qualified as CCoinSelection +import Cardano.Ledger.Binary qualified as CBOR +import Cardano.Ledger.Conway (Conway) + +import Cardano.CoinSelection.Size qualified as CWallet +import Cardano.CoinSelection.UTxOIndex qualified as CWallet +import Cardano.CoinSelection.UTxOSelection qualified as CWallet +import Cardano.Wallet.Primitive.Types.Address qualified as CWallet +import Cardano.Wallet.Primitive.Types.AssetId qualified as CTokenBundle +import Cardano.Wallet.Primitive.Types.AssetName qualified as CWallet +import Cardano.Wallet.Primitive.Types.Coin qualified as CWallet +import Cardano.Wallet.Primitive.Types.Hash qualified as CWallet +import Cardano.Wallet.Primitive.Types.TokenBundle qualified as CTokenBundle +import Cardano.Wallet.Primitive.Types.TokenMap qualified as CWTokenMap +import Cardano.Wallet.Primitive.Types.TokenPolicyId qualified as CWallet +import Cardano.Wallet.Primitive.Types.TokenQuantity qualified as CWallet +import Cardano.Wallet.Primitive.Types.Tx.Constraints qualified as CWallet +import Cardano.Wallet.Primitive.Types.Tx.TxIn qualified as CWallet +import Internal.Cardano.Write.Tx.Balance.CoinSelection qualified as CBalanceInternal ( + SelectionBalanceError (..), + WalletUTxO (..), + ) + +import Cardano.Ledger.Conway.Core (eraProtVerHigh) +import GeniusYield.Imports +import GeniusYield.Transaction.Common +import GeniusYield.Types +import GeniusYield.Utils type GYCoinSelectionContext :: PlutusVersion -> Type data GYCoinSelectionContext v @@ -73,36 +77,36 @@ TODO: - Can we simply use a stripped down 'GYTxIn' for wallet utxo? maybe just GYTxOutRef even. -} instance CCoinSelection.SelectionContext (GYCoinSelectionContext v) where - type Address (GYCoinSelectionContext v) = CWallet.Address - type UTxO (GYCoinSelectionContext v) = CBalanceInternal.WalletUTxO + type Address (GYCoinSelectionContext v) = CWallet.Address + type UTxO (GYCoinSelectionContext v) = CBalanceInternal.WalletUTxO data GYCoinSelectionEnv v = GYCoinSelectionEnv - { existingInputs :: ![GYTxInDetailed v] - -- ^ List of existing inputs that must be used. - , requiredOutputs :: ![(GYAddress, GYValue)] - -- ^ Outputs to pay for. - , mintValue :: !GYValue - -- ^ Value minted in the transaction. - , changeAddr :: GYAddress - -- ^ Address where change outputs will be sent to. - , ownUtxos :: !GYUTxOs - -- ^ Set of own utxos to select additional inputs from. - , extraLovelace :: !Natural - -- ^ Extra lovelace to look for on top of outputs, mainly for fee and any remaining would be given as change output by @makeTransactionBodyAutoBalance@, thus amount remaining besides fees, should satisfy minimum ada requirement else we would have to increase `extraLovelace` parameter. - , minimumUTxOF :: GYTxOut v -> Natural - , maxValueSize :: Natural - , adaSource :: Natural - , adaSink :: Natural - } + { existingInputs :: ![GYTxInDetailed v] + -- ^ List of existing inputs that must be used. + , requiredOutputs :: ![(GYAddress, GYValue)] + -- ^ Outputs to pay for. + , mintValue :: !GYValue + -- ^ Value minted in the transaction. + , changeAddr :: GYAddress + -- ^ Address where change outputs will be sent to. + , ownUtxos :: !GYUTxOs + -- ^ Set of own utxos to select additional inputs from. + , extraLovelace :: !Natural + -- ^ Extra lovelace to look for on top of outputs, mainly for fee and any remaining would be given as change output by @makeTransactionBodyAutoBalance@, thus amount remaining besides fees, should satisfy minimum ada requirement else we would have to increase `extraLovelace` parameter. + , minimumUTxOF :: GYTxOut v -> Natural + , maxValueSize :: Natural + , adaSource :: Natural + , adaSink :: Natural + } data GYCoinSelectionStrategy - = GYLargestFirstMultiAsset - | GYRandomImproveMultiAsset - | GYLegacy - deriving stock (Eq, Show, Enum, Bounded) + = GYLargestFirstMultiAsset + | GYRandomImproveMultiAsset + | GYLegacy + deriving stock (Eq, Show, Enum, Bounded) instance Default GYCoinSelectionStrategy where - def = GYRandomImproveMultiAsset + def = GYRandomImproveMultiAsset {- | Select additional inputs from the set of own utxos given, such that when combined with given existing inputs, they cover for all the given outputs, as well as extraLovelace. @@ -114,146 +118,168 @@ Return the list of additional inputs chosen and the change outputs created. The 'ownUtxos' and 'requiredOutputs' arguments passed must contain non negative 'GYValue's, with each one containing a positive amount of ada. -} -selectInputs :: forall m v. MonadRandom m - => GYCoinSelectionEnv v - -> GYCoinSelectionStrategy - -> ExceptT GYBalancingError m ([GYTxInDetailed v], [GYTxOut v]) +selectInputs :: + forall m v. + (MonadRandom m) => + GYCoinSelectionEnv v -> + GYCoinSelectionStrategy -> + ExceptT GYBalancingError m ([GYTxInDetailed v], [GYTxOut v]) selectInputs - GYCoinSelectionEnv - { existingInputs = existingInputs' - , requiredOutputs - , mintValue - , changeAddr - , ownUtxos - , extraLovelace - , minimumUTxOF - , adaSource - , adaSink - } - GYLegacy = do - additionalInputForReplayProtection <- except $ - if existingInputs' == mempty then -- For replay protection, every transaction must spend at least one UTxO. - -- We pick the UTxO having most value. + GYCoinSelectionEnv + { existingInputs = existingInputs' + , requiredOutputs + , mintValue + , changeAddr + , ownUtxos + , extraLovelace + , minimumUTxOF + , adaSource + , adaSink + } + GYLegacy = do + additionalInputForReplayProtection <- + except $ + if existingInputs' == mempty -- For replay protection, every transaction must spend at least one UTxO. + -- We pick the UTxO having most value. + then let ownUtxosList = utxosToList ownUtxos - in case ownUtxosList of - [] -> Left GYBalancingErrorEmptyOwnUTxOs - _ -> pure . pure $ utxoAsPubKeyInp $ maximumBy (compare `on` utxoValue) ownUtxosList + in case ownUtxosList of + [] -> Left GYBalancingErrorEmptyOwnUTxOs + _ -> pure . pure $ utxoAsPubKeyInp $ maximumBy (compare `on` utxoValue) ownUtxosList else pure Nothing let - additionalInputForReplayProtectionAsList = maybe [] pure additionalInputForReplayProtection - existingInputs = additionalInputForReplayProtectionAsList <> existingInputs' - valueIn, valueOut :: GYValue - valueIn = foldMap gyTxInDetValue existingInputs <> valueFromLovelace (fromIntegral adaSource) - valueOut = foldMap snd requiredOutputs <> valueFromLovelace (fromIntegral adaSink) - valueMissing = missing (valueFromLovelace (fromIntegral extraLovelace) <> valueOut `valueMinus` (valueIn <> mintValue)) - (addIns, addVal) <- except $ selectInputsLegacy - ownUtxos - valueMissing - existingInputs - let valueIn' = valueIn <> addVal + additionalInputForReplayProtectionAsList = maybe [] pure additionalInputForReplayProtection + existingInputs = additionalInputForReplayProtectionAsList <> existingInputs' + valueIn, valueOut :: GYValue + valueIn = foldMap gyTxInDetValue existingInputs <> valueFromLovelace (fromIntegral adaSource) + valueOut = foldMap snd requiredOutputs <> valueFromLovelace (fromIntegral adaSink) + valueMissing = missing (valueFromLovelace (fromIntegral extraLovelace) <> valueOut `valueMinus` (valueIn <> mintValue)) + (addIns, addVal) <- + except $ + selectInputsLegacy + ownUtxos + valueMissing + existingInputs + let valueIn' = valueIn <> addVal tokenChange = removeAda $ (valueIn' <> mintValue) `valueMinus` valueOut changeOuts = - [adjustTxOut minimumUTxOF (GYTxOut changeAddr tokenChange Nothing Nothing) - | not $ isEmptyValue tokenChange - ] + [ adjustTxOut minimumUTxOF (GYTxOut changeAddr tokenChange Nothing Nothing) + | not $ isEmptyValue tokenChange + ] pure (additionalInputForReplayProtectionAsList <> addIns, changeOuts) - where - missing :: GYValue -> Map GYAssetClass Natural - missing v = foldl' f Map.empty $ valueToList v - where - f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural - f m (ac, n) - | n <= 0 = m + where + missing :: GYValue -> Map GYAssetClass Natural + missing v = foldl' f Map.empty $ valueToList v + where + f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural + f m (ac, n) + | n <= 0 = m | otherwise = Map.insert ac (fromIntegral n) m - removeAda :: GYValue -> GYValue - removeAda = snd . valueSplitAda + removeAda :: GYValue -> GYValue + removeAda = snd . valueSplitAda selectInputs - GYCoinSelectionEnv - { existingInputs - , requiredOutputs - , mintValue - , changeAddr - , ownUtxos - , extraLovelace - , minimumUTxOF - , maxValueSize - , adaSource - , adaSink - } - cstrat = do - CBalance.SelectionResult - { inputsSelected - , changeGenerated - } <- modifyException fromCWalletBalancingError - . ExceptT - $ CBalance.performSelection @_ @(GYCoinSelectionContext v) - selectionConstraints - selectionParams - let inRefs = S.fromList $ gyTxInTxOutRef . gyTxInDet <$> existingInputs - changeOuts = map - (\(fromTokenBundle -> tokenChange) -> GYTxOut changeAddr tokenChange Nothing Nothing) - changeGenerated - foldHelper acc (CBalanceInternal.WalletUTxO {txIn}, _) - | fromCWalletTxIn txIn `S.member` inRefs = acc - | otherwise = case utxosLookup (fromCWalletTxIn txIn) ownUtxos of - {- Invariant: The balancer should only select inputs from 'existingInputs' or 'ownUtxos' - Thus, if this txIn doesn't exist in ownUtxos, it must already be in 'existingInputs', - so we don't need it in additional inputs -} - Nothing -> acc - Just utxo -> utxoAsPubKeyInp utxo : acc - -- Set of additional inputs chosen by the balancer that should be added to the transaction. - addIns = foldl' foldHelper [] inputsSelected - pure (addIns, changeOuts) - where - selectionConstraints = CBalance.SelectionConstraints - { tokenBundleSizeAssessor = tokenBundleSizeAssessor - $ CWallet.TxSize maxValueSize - , computeMinimumAdaQuantity = \addr tkMap -> do - -- This function is ran for generated change outputs which do not have datum & reference script. - -- This first parameter can actually be ignored as it will always be @toCWalletAddress changeAddr@. - CWallet.Coin $ minimumUTxOF GYTxOut + GYCoinSelectionEnv + { existingInputs + , requiredOutputs + , mintValue + , changeAddr + , ownUtxos + , extraLovelace + , minimumUTxOF + , maxValueSize + , adaSource + , adaSink + } + cstrat = do + CBalance.SelectionResult + { inputsSelected + , changeGenerated + } <- + modifyException fromCWalletBalancingError + . ExceptT + $ CBalance.performSelection @_ @(GYCoinSelectionContext v) + selectionConstraints + selectionParams + let inRefs = S.fromList $ gyTxInTxOutRef . gyTxInDet <$> existingInputs + changeOuts = + map + (\(fromTokenBundle -> tokenChange) -> GYTxOut changeAddr tokenChange Nothing Nothing) + changeGenerated + foldHelper acc (CBalanceInternal.WalletUTxO {txIn}, _) + | fromCWalletTxIn txIn `S.member` inRefs = acc + | otherwise = case utxosLookup (fromCWalletTxIn txIn) ownUtxos of + {- Invariant: The balancer should only select inputs from 'existingInputs' or 'ownUtxos' + Thus, if this txIn doesn't exist in ownUtxos, it must already be in 'existingInputs', + so we don't need it in additional inputs -} + Nothing -> acc + Just utxo -> utxoAsPubKeyInp utxo : acc + -- Set of additional inputs chosen by the balancer that should be added to the transaction. + addIns = foldl' foldHelper [] inputsSelected + pure (addIns, changeOuts) + where + selectionConstraints = + CBalance.SelectionConstraints + { tokenBundleSizeAssessor = + tokenBundleSizeAssessor $ + CWallet.TxSize maxValueSize + , computeMinimumAdaQuantity = \addr tkMap -> do + -- This function is ran for generated change outputs which do not have datum & reference script. + -- This first parameter can actually be ignored as it will always be @toCWalletAddress changeAddr@. + CWallet.Coin $ + minimumUTxOF + GYTxOut { gyTxOutAddress = fromCWalletAddress addr - , gyTxOutValue = fromTokenMap tkMap - , gyTxOutDatum = Nothing - , gyTxOutRefS = Nothing + , gyTxOutValue = fromTokenMap tkMap + , gyTxOutDatum = Nothing + , gyTxOutRefS = Nothing } - {- This field essentially takes care of tx fees. + , {- This field essentially takes care of tx fees. For simplicity, we simply use the extraLovelace parameter. -} - , computeMinimumCost = const $ CWallet.Coin extraLovelace - , maximumOutputAdaQuantity = CWallet.txOutMaxCoin - , maximumOutputTokenQuantity = CWallet.txOutMaxTokenQuantity - , maximumLengthChangeAddress = toCWalletAddress changeAddr -- Since our change address is fixed. - , nullAddress = CWallet.Address "" - } - selectionParams = CBalance.SelectionParams - { assetsToMint = toTokenMap mintedVal - , assetsToBurn = toTokenMap burnedVal - , extraCoinSource = CWallet.Coin adaSource - , extraCoinSink = CWallet.Coin adaSink - , outputsToCover = map (bimap toCWalletAddress toTokenBundle) requiredOutputs - , utxoAvailable = CWallet.fromIndexPair (ownUtxosIndex, existingInpsIndex) -- `fromIndexPair` would actually make first element to be @ownUtxosIndex `UTxOIndex.difference` existingInpsIndex@. - , selectionStrategy = case cstrat of - GYRandomImproveMultiAsset -> CBalance.SelectionStrategyOptimal - _ -> CBalance.SelectionStrategyMinimal - } - (mintedVal, burnedVal) = valueSplitSign mintValue - ownUtxosIndex = utxosToUtxoIndex ownUtxos - existingInpsIndex = txInDetailedToUtxoIndex existingInputs + computeMinimumCost = const $ CWallet.Coin extraLovelace + , maximumOutputAdaQuantity = CWallet.txOutMaxCoin + , maximumOutputTokenQuantity = CWallet.txOutMaxTokenQuantity + , maximumLengthChangeAddress = toCWalletAddress changeAddr -- Since our change address is fixed. + , nullAddress = CWallet.Address "" + } + selectionParams = + CBalance.SelectionParams + { assetsToMint = toTokenMap mintedVal + , assetsToBurn = toTokenMap burnedVal + , extraCoinSource = CWallet.Coin adaSource + , extraCoinSink = CWallet.Coin adaSink + , outputsToCover = map (bimap toCWalletAddress toTokenBundle) requiredOutputs + , utxoAvailable = CWallet.fromIndexPair (ownUtxosIndex, existingInpsIndex) -- `fromIndexPair` would actually make first element to be @ownUtxosIndex `UTxOIndex.difference` existingInpsIndex@. + , selectionStrategy = case cstrat of + GYRandomImproveMultiAsset -> CBalance.SelectionStrategyOptimal + _ -> CBalance.SelectionStrategyMinimal + } + (mintedVal, burnedVal) = valueSplitSign mintValue + ownUtxosIndex = utxosToUtxoIndex ownUtxos + existingInpsIndex = txInDetailedToUtxoIndex existingInputs computeTokenBundleSerializedLengthBytes :: CTokenBundle.TokenBundle -> CWallet.TxSize -computeTokenBundleSerializedLengthBytes = CWallet.TxSize . safeCast - . BS.length . CBOR.serialize' (eraProtVerHigh @Conway) . Api.S.toMaryValue . toCardanoValue +computeTokenBundleSerializedLengthBytes = + CWallet.TxSize + . safeCast + . BS.length + . CBOR.serialize' (eraProtVerHigh @Conway) + . Api.S.toMaryValue + . toCardanoValue where safeCast :: Int -> Natural safeCast = fromIntegral -selectInputsLegacy :: GYUTxOs -- ^ Set of own utxos to select additional inputs from. - -> Map GYAssetClass Natural -- ^ Target value total inputs must sum up to. - -> [GYTxInDetailed v] -- ^ List of existing inputs that must be used. - -> Either GYBalancingError ([GYTxInDetailed v], GYValue) +selectInputsLegacy :: + -- | Set of own utxos to select additional inputs from. + GYUTxOs -> + -- | Target value total inputs must sum up to. + Map GYAssetClass Natural -> + -- | List of existing inputs that must be used. + [GYTxInDetailed v] -> + Either GYBalancingError ([GYTxInDetailed v], GYValue) selectInputsLegacy ownUtxos targetOut existingIns = go targetOut [] mempty $ utxosToList ownUtxos where inRefs = map (gyTxInTxOutRef . gyTxInDet) existingIns @@ -262,31 +288,32 @@ selectInputsLegacy ownUtxos targetOut existingIns = go targetOut [] mempty $ utx go :: Map GYAssetClass Natural -> [GYTxInDetailed v] -> GYValue -> [GYUTxO] -> Either GYBalancingError ([GYTxInDetailed v], GYValue) go m addIns addVal _ - | Map.null m = Right (addIns, addVal) - go m _ _ [] = Left $ GYBalancingErrorInsufficientFunds $ valueFromList [ (ac, toInteger n) | (ac, n) <- Map.toList m ] + | Map.null m = Right (addIns, addVal) + go m _ _ [] = Left $ GYBalancingErrorInsufficientFunds $ valueFromList [(ac, toInteger n) | (ac, n) <- Map.toList m] go m addIns addVal (utxo : ys) - | utxoRef utxo `elem` inRefs = go m addIns addVal ys - | otherwise = - let v = ownValueMap Map.! utxoRef utxo - m' = foldl' f m $ valueToList v - where - f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural - f m'' (ac, n) = - let - o = fromIntegral n - in - case Map.lookup ac m'' of - Nothing -> m'' - Just n' - | n' <= o -> Map.delete ac m'' - | otherwise -> Map.insert ac (n' - o) m'' - in if m' == m + | utxoRef utxo `elem` inRefs = go m addIns addVal ys + | otherwise = + let v = ownValueMap Map.! utxoRef utxo + m' = foldl' f m $ valueToList v + where + f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural + f m'' (ac, n) = + let + o = fromIntegral n + in + case Map.lookup ac m'' of + Nothing -> m'' + Just n' + | n' <= o -> Map.delete ac m'' + | otherwise -> Map.insert ac (n' - o) m'' + in if m' == m then go m addIns addVal ys - else go - m' - (utxoAsPubKeyInp utxo : addIns) - (addVal <> v) - ys + else + go + m' + (utxoAsPubKeyInp utxo : addIns) + (addVal <> v) + ys ------------------------------------------------------------------------------- -- Utilities @@ -294,56 +321,60 @@ selectInputsLegacy ownUtxos targetOut existingIns = go targetOut [] mempty $ utx utxoAsPubKeyInp :: GYUTxO -> GYTxInDetailed v utxoAsPubKeyInp GYUTxO {utxoRef, utxoAddress, utxoValue, utxoOutDatum, utxoRefScript} = - GYTxInDetailed - -- It is assumed the 'GYUTxOs' arg designates key wallet utxos. - { gyTxInDet = GYTxIn utxoRef GYTxInWitnessKey - , gyTxInDetAddress = utxoAddress - , gyTxInDetValue = fst $ valueSplitSign utxoValue - , gyTxInDetDatum = utxoOutDatum - , gyTxInDetScriptRef = utxoRefScript - } + GYTxInDetailed + { -- It is assumed the 'GYUTxOs' arg designates key wallet utxos. + gyTxInDet = GYTxIn utxoRef GYTxInWitnessKey + , gyTxInDetAddress = utxoAddress + , gyTxInDetValue = fst $ valueSplitSign utxoValue + , gyTxInDetDatum = utxoOutDatum + , gyTxInDetScriptRef = utxoRefScript + } tokenBundleSizeAssessor :: CWallet.TxSize -> CWallet.TokenBundleSizeAssessor tokenBundleSizeAssessor maxSize = CWallet.TokenBundleSizeAssessor {..} where assessTokenBundleSize tb - | serializedLengthBytes <= maxSize = - CWallet.TokenBundleSizeWithinLimit - | otherwise = - CWallet.TokenBundleSizeExceedsLimit + | serializedLengthBytes <= maxSize = + CWallet.TokenBundleSizeWithinLimit + | otherwise = + CWallet.TokenBundleSizeExceedsLimit where serializedLengthBytes :: CWallet.TxSize serializedLengthBytes = computeTokenBundleSerializedLengthBytes tb toCardanoValue :: CTokenBundle.TokenBundle -> Api.S.Value -toCardanoValue tb = Api.S.valueFromList $ - (Api.S.AdaAssetId, coinToQuantity coin) : - map (bimap toCardanoAssetId toQuantity) bundle +toCardanoValue tb = + Api.S.valueFromList $ + (Api.S.AdaAssetId, coinToQuantity coin) + : map (bimap toCardanoAssetId toQuantity) bundle where (coin, bundle) = CTokenBundle.toFlatList tb toCardanoAssetId (CTokenBundle.AssetId pid name) = - Api.S.AssetId (toCardanoPolicyId pid) (toCardanoAssetName name) + Api.S.AssetId (toCardanoPolicyId pid) (toCardanoAssetName name) toCardanoAssetName :: CWallet.AssetName -> Api.S.AssetName toCardanoAssetName (CWallet.UnsafeAssetName tn) = - either (\e -> error $ "toCardanoValue: unable to deserialise, error: " <> show e) id - $ Api.S.deserialiseFromRawBytes Api.S.AsAssetName tn + either (\e -> error $ "toCardanoValue: unable to deserialise, error: " <> show e) id $ + Api.S.deserialiseFromRawBytes Api.S.AsAssetName tn coinToQuantity = fromIntegral . CWallet.unCoin toQuantity = fromIntegral . CWallet.unTokenQuantity toCardanoPolicyId :: CWallet.TokenPolicyId -> Api.S.PolicyId toCardanoPolicyId (CWallet.UnsafeTokenPolicyId (CWallet.Hash pid)) = - either (\e -> error $ "toCardanoPolicyId: unable to deserialise, error: " <> show e) id - $ Api.S.deserialiseFromRawBytes Api.S.AsPolicyId pid + either (\e -> error $ "toCardanoPolicyId: unable to deserialise, error: " <> show e) id $ + Api.S.deserialiseFromRawBytes Api.S.AsPolicyId pid toTokenMap :: GYValue -> CWTokenMap.TokenMap -toTokenMap value = CWTokenMap.fromFlatList $ - map (\(ac, n) -> (toWalletAssetId ac, CWallet.TokenQuantity $ fromIntegral n)) - (valueToList value) +toTokenMap value = + CWTokenMap.fromFlatList $ + map + (\(ac, n) -> (toWalletAssetId ac, CWallet.TokenQuantity $ fromIntegral n)) + (valueToList value) fromTokenMap :: CWTokenMap.TokenMap -> GYValue -fromTokenMap = valueFromList +fromTokenMap = + valueFromList . map (bimap fromWalletAssetId (\(CWallet.TokenQuantity n) -> toInteger n)) . CWTokenMap.toFlatList @@ -351,14 +382,14 @@ toWalletAssetId :: GYAssetClass -> CTokenBundle.AssetId toWalletAssetId GYLovelace = error "toWalletAssetId: unable to deserialize" toWalletAssetId tkn@(GYToken policyId (GYTokenName tokenName)) = CTokenBundle.AssetId tokenPolicy nTokenName where - tokenPolicy = either (customError tkn) id $ fromText $ mintingPolicyIdToText policyId - nTokenName = either (customError tkn) id $ CWallet.fromByteString tokenName - customError t = error $ printf "toWalletAssetId: unable to deserialize \n %s" t + tokenPolicy = either (customError tkn) id $ fromText $ mintingPolicyIdToText policyId + nTokenName = either (customError tkn) id $ CWallet.fromByteString tokenName + customError t = error $ printf "toWalletAssetId: unable to deserialize \n %s" t fromWalletAssetId :: CTokenBundle.AssetId -> GYAssetClass fromWalletAssetId (CTokenBundle.AssetId tokenPolicy nTokenName) = GYToken policyId tkName where - policyId = fromRight customError $ mintingPolicyIdFromText $ toText tokenPolicy + policyId = fromRight customError $ mintingPolicyIdFromText $ toText tokenPolicy tkName = fromMaybe customError $ tokenNameFromBS $ CWallet.unAssetName nTokenName customError = error "fromWalletAssetId: unable to deserialize" @@ -376,29 +407,37 @@ utxosToUtxoIndex :: GYUTxOs -> CWallet.UTxOIndex CBalanceInternal.WalletUTxO utxosToUtxoIndex = CWallet.fromSequence . map utxoToTuple . utxosToList utxoToTuple :: GYUTxO -> (CBalanceInternal.WalletUTxO, CTokenBundle.TokenBundle) -utxoToTuple GYUTxO{ utxoRef - , utxoAddress - , utxoValue - } = (wUtxo,bundle) - where - wUtxo = CBalanceInternal.WalletUTxO { txIn = toCWalletTxIn utxoRef - , address = toCWalletAddress utxoAddress - } - bundle = toTokenBundle utxoValue +utxoToTuple + GYUTxO + { utxoRef + , utxoAddress + , utxoValue + } = (wUtxo, bundle) + where + wUtxo = + CBalanceInternal.WalletUTxO + { txIn = toCWalletTxIn utxoRef + , address = toCWalletAddress utxoAddress + } + bundle = toTokenBundle utxoValue txInDetailedToUtxoIndex :: [GYTxInDetailed v] -> CWallet.UTxOIndex CBalanceInternal.WalletUTxO txInDetailedToUtxoIndex = CWallet.fromSequence . map txInDetailedToTuple txInDetailedToTuple :: GYTxInDetailed v -> (CBalanceInternal.WalletUTxO, CTokenBundle.TokenBundle) -txInDetailedToTuple GYTxInDetailed{ gyTxInDet - , gyTxInDetAddress - , gyTxInDetValue - } = (wUtxo, bundle) - where - wUtxo = CBalanceInternal.WalletUTxO { txIn = toCWalletTxIn $ gyTxInTxOutRef gyTxInDet - , address = toCWalletAddress gyTxInDetAddress - } - bundle = toTokenBundle gyTxInDetValue +txInDetailedToTuple + GYTxInDetailed + { gyTxInDet + , gyTxInDetAddress + , gyTxInDetValue + } = (wUtxo, bundle) + where + wUtxo = + CBalanceInternal.WalletUTxO + { txIn = toCWalletTxIn $ gyTxInTxOutRef gyTxInDet + , address = toCWalletAddress gyTxInDetAddress + } + bundle = toTokenBundle gyTxInDetValue toCWalletAddress :: GYAddress -> CWallet.Address toCWalletAddress = CWallet.Address . Api.serialiseToRawBytes . addressToApi @@ -409,24 +448,25 @@ fromCWalletAddress (CWallet.Address bs) = either customError addressFromApi $ Ap customError e = error $ "fromCWalletAddress: unable to deserialize, error: " <> show e toCWalletTxIn :: GYTxOutRef -> CWallet.TxIn -toCWalletTxIn ref = CWallet.TxIn{ inputId = nTxId - , inputIx = fromIntegral txIx - } +toCWalletTxIn ref = + CWallet.TxIn + { inputId = nTxId + , inputIx = fromIntegral txIx + } where (txId, txIx) = txOutRefToTuple ref nTxId = either customError id $ fromText $ Text.pack $ show txId customError = error "toCWalletTxIn: unable to deserialise" fromCWalletTxIn :: CWallet.TxIn -> GYTxOutRef -fromCWalletTxIn CWallet.TxIn { inputId, inputIx } = txOutRefFromTuple (txId, fromIntegral inputIx) +fromCWalletTxIn CWallet.TxIn {inputId, inputIx} = txOutRefFromTuple (txId, fromIntegral inputIx) where txId = fromMaybe customError . txIdFromHex . Text.unpack $ toText inputId customError = error "fromCWalletTxIn: unable to deserialise txId" fromCWalletBalancingError :: CBalanceInternal.SelectionBalanceError ctx -> GYBalancingError fromCWalletBalancingError (CBalance.BalanceInsufficient (CBalance.BalanceInsufficientError _ _ delta)) = - GYBalancingErrorInsufficientFunds $ fromTokenBundle delta - + GYBalancingErrorInsufficientFunds $ fromTokenBundle delta fromCWalletBalancingError (CBalance.UnableToConstructChange (CBalance.UnableToConstructChangeError _ n)) = - GYBalancingErrorChangeShortFall $ CWallet.unCoin n + GYBalancingErrorChangeShortFall $ CWallet.unCoin n fromCWalletBalancingError CBalance.EmptyUTxO = GYBalancingErrorEmptyOwnUTxOs diff --git a/src/GeniusYield/Transaction/CoinSelection/Types.hs b/src/GeniusYield/Transaction/CoinSelection/Types.hs index 4cae2fd5..e3f255eb 100644 --- a/src/GeniusYield/Transaction/CoinSelection/Types.hs +++ b/src/GeniusYield/Transaction/CoinSelection/Types.hs @@ -1,24 +1,23 @@ -{-| +{- | Module : GeniusYield.Transaction.CoinSelection.Types Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Transaction.CoinSelection.Types (CoinSelection (..)) where import GeniusYield.Transaction.Common (GYTxInDetailed) -import GeniusYield.Types.Value (GYValue) +import GeniusYield.Types.Value (GYValue) data CoinSelection v = CoinSelection - { inputs :: ![GYTxInDetailed v] - , change :: ![GYValue] - } + { inputs :: ![GYTxInDetailed v] + , change :: ![GYValue] + } instance Semigroup (CoinSelection v) where - CoinSelection{inputs=ia, change=ca} <> CoinSelection{inputs=ib, change=cb} = - CoinSelection { inputs = ia <> ib, change = ca <> cb } + CoinSelection {inputs = ia, change = ca} <> CoinSelection {inputs = ib, change = cb} = + CoinSelection {inputs = ia <> ib, change = ca <> cb} instance Monoid (CoinSelection v) where - mempty = CoinSelection mempty mempty + mempty = CoinSelection mempty mempty diff --git a/src/GeniusYield/Transaction/Common.hs b/src/GeniusYield/Transaction/Common.hs index d39925fc..d1b9c084 100644 --- a/src/GeniusYield/Transaction/Common.hs +++ b/src/GeniusYield/Transaction/Common.hs @@ -1,43 +1,40 @@ -{-| +{- | Module : GeniusYield.Transaction.Common Description : Common utility types used during transaction building and coin selection. Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} - module GeniusYield.Transaction.Common ( - GYBalancedTx (..), - GYTxInDetailed (..), - utxoFromTxInDetailed, - GYBuildTxError (..), - GYBalancingError (..), - minimumUTxO, - adjustTxOut + GYBalancedTx (..), + GYTxInDetailed (..), + utxoFromTxInDetailed, + GYBuildTxError (..), + GYBalancingError (..), + minimumUTxO, + adjustTxOut, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Ledger.Coin as Ledger -import GeniusYield.Imports -import GeniusYield.Transaction.CBOR -import GeniusYield.Types.Address -import GeniusYield.Types.Era -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) -import GeniusYield.Types.PubKeyHash -import GeniusYield.Types.Redeemer -import GeniusYield.Types.Script -import GeniusYield.Types.Slot -import GeniusYield.Types.TxCert.Internal -import GeniusYield.Types.TxIn -import GeniusYield.Types.TxMetadata -import GeniusYield.Types.TxOut -import GeniusYield.Types.TxWdrl -import GeniusYield.Types.UTxO -import GeniusYield.Types.Value -import qualified Text.Printf as Printf - +import Cardano.Api qualified as Api +import Cardano.Ledger.Coin qualified as Ledger +import GeniusYield.Imports +import GeniusYield.Transaction.CBOR +import GeniusYield.Types.Address +import GeniusYield.Types.Era +import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) +import GeniusYield.Types.PubKeyHash +import GeniusYield.Types.Redeemer +import GeniusYield.Types.Script +import GeniusYield.Types.Slot +import GeniusYield.Types.TxCert.Internal +import GeniusYield.Types.TxIn +import GeniusYield.Types.TxMetadata +import GeniusYield.Types.TxOut +import GeniusYield.Types.TxWdrl +import GeniusYield.Types.UTxO +import GeniusYield.Types.Value +import Text.Printf qualified as Printf {- | An *almost* finalized Tx. @@ -45,27 +42,27 @@ This is fully balanced _except_ potentially missing an ada change output, and mi Both of these will be set by 'GeniusYield.Transaction.finalizeGYBalancedTx'. -} data GYBalancedTx v = GYBalancedTx - { gybtxIns :: ![GYTxInDetailed v] - , gybtxCollaterals :: !GYUTxOs - , gybtxOuts :: ![GYTxOut v] - , gybtxMint :: !(Maybe (GYValue, [(GYMintScript v, GYRedeemer)])) - , gybtxWdrls :: ![GYTxWdrl v] - , gybtxCerts :: ![GYTxCert' v] - , gybtxInvalidBefore :: !(Maybe GYSlot) - , gybtxInvalidAfter :: !(Maybe GYSlot) - , gybtxSigners :: !(Set GYPubKeyHash) - , gybtxRefIns :: !GYUTxOs - , gybtxMetadata :: !(Maybe GYTxMetadata) - } + { gybtxIns :: ![GYTxInDetailed v] + , gybtxCollaterals :: !GYUTxOs + , gybtxOuts :: ![GYTxOut v] + , gybtxMint :: !(Maybe (GYValue, [(GYMintScript v, GYRedeemer)])) + , gybtxWdrls :: ![GYTxWdrl v] + , gybtxCerts :: ![GYTxCert' v] + , gybtxInvalidBefore :: !(Maybe GYSlot) + , gybtxInvalidAfter :: !(Maybe GYSlot) + , gybtxSigners :: !(Set GYPubKeyHash) + , gybtxRefIns :: !GYUTxOs + , gybtxMetadata :: !(Maybe GYTxMetadata) + } -- | A further detailed version of 'GYTxIn', containing all information about a UTxO. data GYTxInDetailed v = GYTxInDetailed - { gyTxInDet :: !(GYTxIn v) - , gyTxInDetAddress :: !GYAddress - , gyTxInDetValue :: !GYValue - , gyTxInDetDatum :: !GYOutDatum - , gyTxInDetScriptRef :: !(Maybe GYAnyScript) - } + { gyTxInDet :: !(GYTxIn v) + , gyTxInDetAddress :: !GYAddress + , gyTxInDetValue :: !GYValue + , gyTxInDetDatum :: !GYOutDatum + , gyTxInDetScriptRef :: !(Maybe GYAnyScript) + } deriving (Eq, Show) utxoFromTxInDetailed :: GYTxInDetailed v -> GYUTxO @@ -76,67 +73,78 @@ utxoFromTxInDetailed (GYTxInDetailed (GYTxIn ref _witns) addr val d ms) = GYUTxO ------------------------------------------------------------------------------- data GYBalancingError - = GYBalancingErrorInsufficientFunds !GYValue - | forall v. GYBalancingErrorNonPositiveTxOut !(GYTxOut v) - | GYBalancingErrorChangeShortFall !Natural - -- ^ Lovelace shortfall in constructing a change output. See: "Cardano.CoinSelection.Balance.UnableToConstructChangeError" - | GYBalancingErrorEmptyOwnUTxOs - -- ^ User wallet has no utxos to select. + = GYBalancingErrorInsufficientFunds !GYValue + | forall v. GYBalancingErrorNonPositiveTxOut !(GYTxOut v) + | -- | Lovelace shortfall in constructing a change output. See: "Cardano.CoinSelection.Balance.UnableToConstructChangeError" + GYBalancingErrorChangeShortFall !Natural + | -- | User wallet has no utxos to select. + GYBalancingErrorEmptyOwnUTxOs deriving stock instance Show GYBalancingError instance Printf.PrintfArg GYBalancingError where - formatArg = Printf.formatArg . show + formatArg = Printf.formatArg . show instance Eq GYBalancingError where - GYBalancingErrorInsufficientFunds v1 == GYBalancingErrorInsufficientFunds v2 = v1 == v2 - GYBalancingErrorChangeShortFall n1 == GYBalancingErrorChangeShortFall n2 = n1 == n2 - GYBalancingErrorEmptyOwnUTxOs == GYBalancingErrorEmptyOwnUTxOs = True - GYBalancingErrorNonPositiveTxOut out1 == GYBalancingErrorNonPositiveTxOut out2 = txOutToApi out1 == txOutToApi out2 - _ == _ = False - --- | 'GYBuildTxError' may be raised when building transactions, for non-trivial errors. --- Insufficient funds and similar are considered trivial transaction building errors. + GYBalancingErrorInsufficientFunds v1 == GYBalancingErrorInsufficientFunds v2 = v1 == v2 + GYBalancingErrorChangeShortFall n1 == GYBalancingErrorChangeShortFall n2 = n1 == n2 + GYBalancingErrorEmptyOwnUTxOs == GYBalancingErrorEmptyOwnUTxOs = True + GYBalancingErrorNonPositiveTxOut out1 == GYBalancingErrorNonPositiveTxOut out2 = txOutToApi out1 == txOutToApi out2 + _ == _ = False + +{- | 'GYBuildTxError' may be raised when building transactions, for non-trivial errors. +Insufficient funds and similar are considered trivial transaction building errors. +-} data GYBuildTxError - = GYBuildTxBalancingError !GYBalancingError - | GYBuildTxBodyErrorAutoBalance !(Api.TxBodyErrorAutoBalance ApiEra) - | GYBuildTxExUnitsTooBig -- ^ Execution units required is higher than the maximum as specified by protocol params. - (Natural, Natural) -- ^ Tuple of maximum execution steps & memory as given by protocol parameters. - (Natural, Natural) -- ^ Tuple of execution steps & memory as taken by built transaction. - - | GYBuildTxSizeTooBig -- ^ Transaction size is higher than the maximum as specified by protocol params. - !Natural -- ^ Maximum size as specified by protocol parameters. - !Natural -- ^ Size our built transaction took. - | GYBuildTxCollateralShortFall -- ^ Shortfall (in collateral inputs) for collateral requirement. - !Natural -- ^ Transaction collateral requirement. - !Natural -- ^ Lovelaces in given collateral UTxO. - | GYBuildTxNoSuitableCollateral - -- ^ Couldn't find a UTxO to use as collateral. - | GYBuildTxCborSimplificationError !CborSimplificationError - | GYBuildTxCollapseExtraOutError !Api.TxBodyError - deriving stock Show + = GYBuildTxBalancingError !GYBalancingError + | GYBuildTxBodyErrorAutoBalance !(Api.TxBodyErrorAutoBalance ApiEra) + | -- | Execution units required is higher than the maximum as specified by protocol params. + GYBuildTxExUnitsTooBig + -- | Tuple of maximum execution steps & memory as given by protocol parameters. + (Natural, Natural) + -- | Tuple of execution steps & memory as taken by built transaction. + (Natural, Natural) + | -- | Transaction size is higher than the maximum as specified by protocol params. + GYBuildTxSizeTooBig + -- | Maximum size as specified by protocol parameters. + !Natural + -- | Size our built transaction took. + !Natural + | -- | Shortfall (in collateral inputs) for collateral requirement. + GYBuildTxCollateralShortFall + -- | Transaction collateral requirement. + !Natural + -- | Lovelaces in given collateral UTxO. + !Natural + | -- | Couldn't find a UTxO to use as collateral. + GYBuildTxNoSuitableCollateral + | GYBuildTxCborSimplificationError !CborSimplificationError + | GYBuildTxCollapseExtraOutError !Api.TxBodyError + deriving stock (Show) ------------------------------------------------------------------------------- -- Transaction Utilities ------------------------------------------------------------------------------- minimumUTxO :: ApiProtocolParameters -> GYTxOut v -> Natural -minimumUTxO pp txOut = fromInteger $ coerce $ - Api.calculateMinimumUTxO Api.ShelleyBasedEraConway (txOutToApi txOut) pp +minimumUTxO pp txOut = + fromInteger $ + coerce $ + Api.calculateMinimumUTxO Api.ShelleyBasedEraConway (txOutToApi txOut) pp adjustTxOut :: (GYTxOut v -> Natural) -> GYTxOut v -> GYTxOut v adjustTxOut minimumUTxOF = helper where helper txOut = - let v = gyTxOutValue txOut - needed = minimumUTxOF txOut - contained = extractLovelace $ valueToApi v - in if needed <= contained + let v = gyTxOutValue txOut + needed = minimumUTxOF txOut + contained = extractLovelace $ valueToApi v + in if needed <= contained then txOut else - let v' = valueFromLovelace (fromIntegral $ needed - contained) <> v - txOut' = txOut {gyTxOutValue = v'} - in helper txOut' + let v' = valueFromLovelace (fromIntegral $ needed - contained) <> v + txOut' = txOut {gyTxOutValue = v'} + in helper txOut' extractLovelace :: Api.Value -> Natural extractLovelace v = case Api.selectLovelace v of Ledger.Coin n -> fromIntegral $ max 0 n diff --git a/src/GeniusYield/TxBuilder.hs b/src/GeniusYield/TxBuilder.hs index 55dd6237..129f70f2 100644 --- a/src/GeniusYield/TxBuilder.hs +++ b/src/GeniusYield/TxBuilder.hs @@ -1,98 +1,107 @@ -{-| +{- | Module : GeniusYield.TxBuilder Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.TxBuilder - ( module X - , queryBalance - , queryBalances - , getAdaOnlyUTxO - , adaOnlyUTxOPure - , getCollateral' - , getCollateral - , getTxBalance - ) where +module GeniusYield.TxBuilder ( + module X, + queryBalance, + queryBalances, + getAdaOnlyUTxO, + adaOnlyUTxOPure, + getCollateral', + getCollateral, + getTxBalance, +) where -import qualified Cardano.Api as Api -import qualified Data.Map.Strict as Map +import Cardano.Api qualified as Api +import Data.Map.Strict qualified as Map -import GeniusYield.TxBuilder.Class as X hiding (signTxBodyImpl, signTxBodyWithStakeImpl) -import GeniusYield.TxBuilder.Common as X -import GeniusYield.TxBuilder.Errors as X -import GeniusYield.TxBuilder.IO as X -import GeniusYield.TxBuilder.User as X +import GeniusYield.TxBuilder.Class as X hiding (signTxBodyImpl, signTxBodyWithStakeImpl) +import GeniusYield.TxBuilder.Common as X +import GeniusYield.TxBuilder.Errors as X +import GeniusYield.TxBuilder.IO as X +import GeniusYield.TxBuilder.User as X -import GeniusYield.Imports -import GeniusYield.Types +import GeniusYield.Imports +import GeniusYield.Types -- | Query the balance at given address. -queryBalance :: GYTxQueryMonad m => GYAddress -> m GYValue +queryBalance :: (GYTxQueryMonad m) => GYAddress -> m GYValue queryBalance addr = foldMapUTxOs utxoValue <$> utxosAtAddress addr Nothing -- | Query the balances at given addresses. -queryBalances :: GYTxQueryMonad m => [GYAddress] -> m GYValue +queryBalances :: (GYTxQueryMonad m) => [GYAddress] -> m GYValue queryBalances addrs = foldMapUTxOs utxoValue <$> utxosAtAddresses addrs --- | Query the txoutrefs at given address with ADA-only values. --- --- Useful for finding a txoutref to be used as collateral. -getAdaOnlyUTxO :: GYTxQueryMonad m => GYAddress -> m [(GYTxOutRef, Natural)] +{- | Query the txoutrefs at given address with ADA-only values. + +Useful for finding a txoutref to be used as collateral. +-} +getAdaOnlyUTxO :: (GYTxQueryMonad m) => GYAddress -> m [(GYTxOutRef, Natural)] getAdaOnlyUTxO addr = adaOnlyUTxOPure <$> utxosAtAddress addr Nothing -- | Get a UTxO suitable for use as collateral. --- -getCollateral' :: GYTxQueryMonad m - => GYAddress -- ^ The address where to look. - -> Natural -- ^ The minimal amount of lovelace required as collateral. - -> m (Maybe (GYTxOutRef, Natural)) -- ^ Returns the smallest ada-only UTxO and the contained amount of lovelace at the specified address with the specified minimal value. If no such UTxO exists, 'Nothing' is returned. +getCollateral' :: + (GYTxQueryMonad m) => + -- | The address where to look. + GYAddress -> + -- | The minimal amount of lovelace required as collateral. + Natural -> + -- | Returns the smallest ada-only UTxO and the contained amount of lovelace at the specified address with the specified minimal value. If no such UTxO exists, 'Nothing' is returned. + m (Maybe (GYTxOutRef, Natural)) getCollateral' addr minCollateral = do - xs <- filter (\(_, n) -> n >= minCollateral) <$> getAdaOnlyUTxO addr - return $ case xs of - [] -> Nothing - ys -> Just $ minimumBy (compare `on` snd) ys + xs <- filter (\(_, n) -> n >= minCollateral) <$> getAdaOnlyUTxO addr + return $ case xs of + [] -> Nothing + ys -> Just $ minimumBy (compare `on` snd) ys -- | Get an UTxO suitable for use as collateral. --- -getCollateral :: GYTxQueryMonad m - => GYAddress -- ^ The address where to look. - -> Natural -- ^ The minimal amount of lovelace required as collateral. - -> m (GYTxOutRef, Natural) -- ^ Returns the smallest ada-only UTxO and the contained amount of lovelace at the specified address with the specified minimal value. If no such UTxO exists, an exception is thrown. +getCollateral :: + (GYTxQueryMonad m) => + -- | The address where to look. + GYAddress -> + -- | The minimal amount of lovelace required as collateral. + Natural -> + -- | Returns the smallest ada-only UTxO and the contained amount of lovelace at the specified address with the specified minimal value. If no such UTxO exists, an exception is thrown. + m (GYTxOutRef, Natural) getCollateral addr minCollateral = do - mc <- getCollateral' addr minCollateral - case mc of - Nothing -> throwError $ GYNoSuitableCollateralException minCollateral addr - Just x -> return x + mc <- getCollateral' addr minCollateral + case mc of + Nothing -> throwError $ GYNoSuitableCollateralException minCollateral addr + Just x -> return x adaOnlyUTxOPure :: GYUTxOs -> [(GYTxOutRef, Natural)] adaOnlyUTxOPure = Map.toList . mapMaybeUTxOs (valueIsPositiveAda . utxoValue) where valueIsPositiveAda :: GYValue -> Maybe Natural valueIsPositiveAda v = case valueSplitAda v of - (n, v') | n > 0, isEmptyValue v' -> Just (fromInteger n) - _ -> Nothing + (n, v') | n > 0, isEmptyValue v' -> Just (fromInteger n) + _ -> Nothing --- | Calculate how much balance is the given transaction --- is moving to given pubkeyhash address(es). -getTxBalance :: GYTxQueryMonad m => GYPubKeyHash -> GYTx -> m GYValue +{- | Calculate how much balance is the given transaction +is moving to given pubkeyhash address(es). +-} +getTxBalance :: (GYTxQueryMonad m) => GYPubKeyHash -> GYTx -> m GYValue getTxBalance pkh tx = do - let Api.TxBody content = Api.getTxBody $ txToApi tx - ins = txOutRefFromApi . fst <$> Api.txIns content - outValue = mconcat [ valueFromApiTxOutValue v - | Api.TxOut a v _ _ <- Api.txOuts content - , isRelevantAddress $ addressFromApi' a - ] - utxos <- utxosAtTxOutRefs ins - let inValue = foldMapUTxOs f utxos - return $ outValue `valueMinus` inValue + let Api.TxBody content = Api.getTxBody $ txToApi tx + ins = txOutRefFromApi . fst <$> Api.txIns content + outValue = + mconcat + [ valueFromApiTxOutValue v + | Api.TxOut a v _ _ <- Api.txOuts content + , isRelevantAddress $ addressFromApi' a + ] + utxos <- utxosAtTxOutRefs ins + let inValue = foldMapUTxOs f utxos + return $ outValue `valueMinus` inValue where isRelevantAddress :: GYAddress -> Bool isRelevantAddress addr = Just pkh == addressToPubKeyHash addr f :: GYUTxO -> GYValue f utxo - | isRelevantAddress $ utxoAddress utxo = utxoValue utxo - | otherwise = mempty + | isRelevantAddress $ utxoAddress utxo = utxoValue utxo + | otherwise = mempty diff --git a/src/GeniusYield/TxBuilder/Class.hs b/src/GeniusYield/TxBuilder/Class.hs index eb427776..9a53572b 100644 --- a/src/GeniusYield/TxBuilder/Class.hs +++ b/src/GeniusYield/TxBuilder/Class.hs @@ -1,259 +1,271 @@ -{-| +{- | Module : GeniusYield.TxBuilder.Class Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.TxBuilder.Class - ( MonadError (..) - , MonadRandom (..) - , GYTxGameMonad (..) - , GYTxMonad (..) - , signTxBodyImpl - , signTxBodyWithStakeImpl - , GYTxBuilderMonad (..) - , GYTxQueryMonad (..) - , GYTxSpecialQueryMonad (..) - , GYTxUserQueryMonad (..) - , GYTxSkeleton (..) - , GYTxSkeletonRefIns (..) - , buildTxBody - , buildTxBodyParallel - , buildTxBodyChaining - , waitNSlots - , waitNSlots_ - , waitUntilSlot_ - , submitTx_ - , submitTxConfirmed - , submitTxConfirmed_ - , submitTxConfirmed' - , submitTxConfirmed'_ - , submitTxBody - , submitTxBody_ - , submitTxBodyConfirmed - , submitTxBodyConfirmed_ - , signAndSubmitConfirmed - , signAndSubmitConfirmed_ - , awaitTxConfirmed - , gyTxSkeletonRefInsToList - , gyTxSkeletonRefInsSet - , lookupDatum' - , utxoAtTxOutRef' - , utxoAtTxOutRefWithDatum' - , someUTxOWithoutRefScript - , slotToBeginTime - , slotToEndTime - , enclosingSlotFromTime - , enclosingSlotFromTime' - , scriptAddress - , scriptAddress' - , addressFromText' - , addressFromPlutusM - , addressFromPlutusHushedM - , addressFromPlutus' - , addressToPubKeyHash' - , addressToPubKeyHashIO - , addressToValidatorHash' - , addressToValidatorHashIO - , valueFromPlutus' - , valueFromPlutusIO - , makeAssetClass' - , makeAssetClassIO - , assetClassFromPlutus' - , tokenNameFromPlutus' - , txOutRefFromPlutus' - , datumHashFromPlutus' - , pubKeyHashFromPlutus' - , advanceSlot' - , utxosDatums - , utxosDatumsPure - , utxosDatumsPureWithOriginalDatum - , utxoDatum - , utxoDatumPure - , utxoDatumPureWithOriginalDatum - , utxoDatumHushed - , utxoDatumPureHushed - , utxoDatumPureHushedWithOriginalDatum - , utxoDatum' - , utxoDatumPure' - , utxoDatumPureWithOriginalDatum' - , mustHaveInput - , mustHaveRefInput - , mustHaveOutput - , mustHaveOptionalOutput - , mustHaveTxMetadata - , mustMint - , mustHaveWithdrawal - , mustHaveCertificate - , mustBeSignedBy - , isInvalidBefore - , isInvalidAfter - , gyLogDebug' - , gyLogInfo' - , gyLogWarning' - , gyLogError' - , skeletonToRefScriptsORefs - , wrapReqWithTimeLog - , wt - ) where - -import Control.Monad.Except (MonadError (..), liftEither) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Random (MonadRandom (..), RandT, - lift) -import Control.Monad.Reader (ReaderT) -import qualified Control.Monad.State.Lazy as Lazy -import qualified Control.Monad.State.Strict as Strict -import qualified Control.Monad.Writer.CPS as CPS -import qualified Control.Monad.Writer.Lazy as Lazy -import qualified Control.Monad.Writer.Strict as Strict -import Data.Default (Default, def) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import Data.Maybe (maybeToList) -import qualified Data.Set as Set -import qualified Data.Text as Txt -import Data.Time (diffUTCTime, getCurrentTime) -import Data.Word (Word64) -import GeniusYield.Imports -import GeniusYield.Transaction -import GeniusYield.TxBuilder.Common -import GeniusYield.TxBuilder.Errors -import GeniusYield.TxBuilder.Query.Class -import GeniusYield.TxBuilder.User -import GeniusYield.Types -import GeniusYield.Types.Key.Class (ToShelleyWitnessSigningKey) -import GHC.Stack (withFrozenCallStack) -import qualified PlutusLedgerApi.V1 as Plutus (Address, - DatumHash, - FromData (..), - PubKeyHash, - TokenName, - TxOutRef, Value) -import qualified PlutusLedgerApi.V1.Value as Plutus (AssetClass) +module GeniusYield.TxBuilder.Class ( + MonadError (..), + MonadRandom (..), + GYTxGameMonad (..), + GYTxMonad (..), + signTxBodyImpl, + signTxBodyWithStakeImpl, + GYTxBuilderMonad (..), + GYTxQueryMonad (..), + GYTxSpecialQueryMonad (..), + GYTxUserQueryMonad (..), + GYTxSkeleton (..), + GYTxSkeletonRefIns (..), + buildTxBody, + buildTxBodyParallel, + buildTxBodyChaining, + waitNSlots, + waitNSlots_, + waitUntilSlot_, + submitTx_, + submitTxConfirmed, + submitTxConfirmed_, + submitTxConfirmed', + submitTxConfirmed'_, + submitTxBody, + submitTxBody_, + submitTxBodyConfirmed, + submitTxBodyConfirmed_, + signAndSubmitConfirmed, + signAndSubmitConfirmed_, + awaitTxConfirmed, + gyTxSkeletonRefInsToList, + gyTxSkeletonRefInsSet, + lookupDatum', + utxoAtTxOutRef', + utxoAtTxOutRefWithDatum', + someUTxOWithoutRefScript, + slotToBeginTime, + slotToEndTime, + enclosingSlotFromTime, + enclosingSlotFromTime', + scriptAddress, + scriptAddress', + addressFromText', + addressFromPlutusM, + addressFromPlutusHushedM, + addressFromPlutus', + addressToPubKeyHash', + addressToPubKeyHashIO, + addressToValidatorHash', + addressToValidatorHashIO, + valueFromPlutus', + valueFromPlutusIO, + makeAssetClass', + makeAssetClassIO, + assetClassFromPlutus', + tokenNameFromPlutus', + txOutRefFromPlutus', + datumHashFromPlutus', + pubKeyHashFromPlutus', + advanceSlot', + utxosDatums, + utxosDatumsPure, + utxosDatumsPureWithOriginalDatum, + utxoDatum, + utxoDatumPure, + utxoDatumPureWithOriginalDatum, + utxoDatumHushed, + utxoDatumPureHushed, + utxoDatumPureHushedWithOriginalDatum, + utxoDatum', + utxoDatumPure', + utxoDatumPureWithOriginalDatum', + mustHaveInput, + mustHaveRefInput, + mustHaveOutput, + mustHaveOptionalOutput, + mustHaveTxMetadata, + mustMint, + mustHaveWithdrawal, + mustHaveCertificate, + mustBeSignedBy, + isInvalidBefore, + isInvalidAfter, + gyLogDebug', + gyLogInfo', + gyLogWarning', + gyLogError', + skeletonToRefScriptsORefs, + wrapReqWithTimeLog, + wt, +) where + +import Control.Monad.Except (MonadError (..), liftEither) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Random ( + MonadRandom (..), + RandT, + lift, + ) +import Control.Monad.Reader (ReaderT) +import Control.Monad.State.Lazy qualified as Lazy +import Control.Monad.State.Strict qualified as Strict +import Control.Monad.Writer.CPS qualified as CPS +import Control.Monad.Writer.Lazy qualified as Lazy +import Control.Monad.Writer.Strict qualified as Strict +import Data.Default (Default, def) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.Maybe (maybeToList) +import Data.Set qualified as Set +import Data.Text qualified as Txt +import Data.Time (diffUTCTime, getCurrentTime) +import Data.Word (Word64) +import GHC.Stack (withFrozenCallStack) +import GeniusYield.Imports +import GeniusYield.Transaction +import GeniusYield.TxBuilder.Common +import GeniusYield.TxBuilder.Errors +import GeniusYield.TxBuilder.Query.Class +import GeniusYield.TxBuilder.User +import GeniusYield.Types +import GeniusYield.Types.Key.Class (ToShelleyWitnessSigningKey) +import PlutusLedgerApi.V1 qualified as Plutus ( + Address, + DatumHash, + FromData (..), + PubKeyHash, + TokenName, + TxOutRef, + Value, + ) +import PlutusLedgerApi.V1.Value qualified as Plutus (AssetClass) -- NOTE: The 'Default (TxBuilderStrategy m)' constraint is not necessary, but it is usually desired everytime -- someone is building transactions with the below machinery. --- | Class of monads for building transactions. This can be default derived if the requirements are met. --- Specifically, set 'TxBuilderStrategy' to 'GYCoinSelectionStrategy' if you wish to use the default in-house --- transaction building implementation. + +{- | Class of monads for building transactions. This can be default derived if the requirements are met. +Specifically, set 'TxBuilderStrategy' to 'GYCoinSelectionStrategy' if you wish to use the default in-house +transaction building implementation. +-} class (Default (TxBuilderStrategy m), GYTxSpecialQueryMonad m, GYTxUserQueryMonad m) => GYTxBuilderMonad m where - type TxBuilderStrategy m :: Type - type TxBuilderStrategy m = GYCoinSelectionStrategy - - {- | The most basic version of 'GYTxSkeleton' builder. - - == NOTE == - This is not meant to be called multiple times with several 'GYTxSkeleton's before submission. - Because the balancer will end up using the same utxos across the different txs. - - Consider using 'buildTxBodyParallel' or 'buildTxBodyChaining' instead. - -} - buildTxBodyWithStrategy :: forall v. TxBuilderStrategy m -> GYTxSkeleton v -> m GYTxBody - default buildTxBodyWithStrategy :: forall v. (MonadRandom m, TxBuilderStrategy m ~ GYCoinSelectionStrategy) - => TxBuilderStrategy m - -> GYTxSkeleton v - -> m GYTxBody - buildTxBodyWithStrategy = buildTxBodyWithStrategy' - - {- | A multi 'GYTxSkeleton' builder. The result containing built bodies must be in the same order as the skeletons. - - This does not perform chaining, i.e does not use utxos created by one of the given transactions in the next one. - However, it does ensure that the balancer does not end up using the same own utxos when building multiple - transactions at once. - - This supports failure recovery by utilizing 'GYTxBuildResult'. - -} - buildTxBodyParallelWithStrategy :: forall v. TxBuilderStrategy m -> [GYTxSkeleton v] -> m GYTxBuildResult - default buildTxBodyParallelWithStrategy :: forall v. (MonadRandom m, TxBuilderStrategy m ~ GYCoinSelectionStrategy) - => TxBuilderStrategy m - -> [GYTxSkeleton v] - -> m GYTxBuildResult - buildTxBodyParallelWithStrategy = buildTxBodyParallelWithStrategy' - - {- | A chaining 'GYTxSkeleton' builder. The result containing built bodies must be in the same order as the skeletons. - - This will perform chaining, i.e it will use utxos created by one of the given transactions, when building the next one. - - This supports failure recovery by utilizing 'GYTxBuildResult'. - -} - buildTxBodyChainingWithStrategy :: forall v. TxBuilderStrategy m -> [GYTxSkeleton v] -> m GYTxBuildResult - default buildTxBodyChainingWithStrategy :: forall v. (MonadRandom m, TxBuilderStrategy m ~ GYCoinSelectionStrategy) - => TxBuilderStrategy m - -> [GYTxSkeleton v] - -> m GYTxBuildResult - buildTxBodyChainingWithStrategy = buildTxBodyChainingWithStrategy' + type TxBuilderStrategy m :: Type + type TxBuilderStrategy m = GYCoinSelectionStrategy + + -- | The most basic version of 'GYTxSkeleton' builder. + -- + -- == NOTE == + -- This is not meant to be called multiple times with several 'GYTxSkeleton's before submission. + -- Because the balancer will end up using the same utxos across the different txs. + -- + -- Consider using 'buildTxBodyParallel' or 'buildTxBodyChaining' instead. + buildTxBodyWithStrategy :: forall v. TxBuilderStrategy m -> GYTxSkeleton v -> m GYTxBody + default buildTxBodyWithStrategy :: + forall v. + (MonadRandom m, TxBuilderStrategy m ~ GYCoinSelectionStrategy) => + TxBuilderStrategy m -> + GYTxSkeleton v -> + m GYTxBody + buildTxBodyWithStrategy = buildTxBodyWithStrategy' + + -- | A multi 'GYTxSkeleton' builder. The result containing built bodies must be in the same order as the skeletons. + -- + -- This does not perform chaining, i.e does not use utxos created by one of the given transactions in the next one. + -- However, it does ensure that the balancer does not end up using the same own utxos when building multiple + -- transactions at once. + -- + -- This supports failure recovery by utilizing 'GYTxBuildResult'. + buildTxBodyParallelWithStrategy :: forall v. TxBuilderStrategy m -> [GYTxSkeleton v] -> m GYTxBuildResult + default buildTxBodyParallelWithStrategy :: + forall v. + (MonadRandom m, TxBuilderStrategy m ~ GYCoinSelectionStrategy) => + TxBuilderStrategy m -> + [GYTxSkeleton v] -> + m GYTxBuildResult + buildTxBodyParallelWithStrategy = buildTxBodyParallelWithStrategy' + + -- | A chaining 'GYTxSkeleton' builder. The result containing built bodies must be in the same order as the skeletons. + -- + -- This will perform chaining, i.e it will use utxos created by one of the given transactions, when building the next one. + -- + -- This supports failure recovery by utilizing 'GYTxBuildResult'. + buildTxBodyChainingWithStrategy :: forall v. TxBuilderStrategy m -> [GYTxSkeleton v] -> m GYTxBuildResult + default buildTxBodyChainingWithStrategy :: + forall v. + (MonadRandom m, TxBuilderStrategy m ~ GYCoinSelectionStrategy) => + TxBuilderStrategy m -> + [GYTxSkeleton v] -> + m GYTxBuildResult + buildTxBodyChainingWithStrategy = buildTxBodyChainingWithStrategy' -- | 'buildTxBodyWithStrategy' with the default coin selection strategy. -buildTxBody :: forall v m. GYTxBuilderMonad m => GYTxSkeleton v -> m GYTxBody +buildTxBody :: forall v m. (GYTxBuilderMonad m) => GYTxSkeleton v -> m GYTxBody buildTxBody = buildTxBodyWithStrategy def -- | 'buildTxBodyParallelWithStrategy' with the default coin selection strategy. -buildTxBodyParallel :: forall v m. GYTxBuilderMonad m => [GYTxSkeleton v] -> m GYTxBuildResult +buildTxBodyParallel :: forall v m. (GYTxBuilderMonad m) => [GYTxSkeleton v] -> m GYTxBuildResult buildTxBodyParallel = buildTxBodyParallelWithStrategy def -- | 'buildTxBodyChainingWithStrategy' with the default coin selection strategy. -buildTxBodyChaining :: forall v m. GYTxBuilderMonad m => [GYTxSkeleton v] -> m GYTxBuildResult +buildTxBodyChaining :: forall v m. (GYTxBuilderMonad m) => [GYTxSkeleton v] -> m GYTxBuildResult buildTxBodyChaining = buildTxBodyChainingWithStrategy def -- | Class of monads for interacting with the blockchain using transactions. -class GYTxBuilderMonad m => GYTxMonad m where - -- | Sign a transaction body with the user payment key to produce a transaction with witnesses. - -- - -- /Note:/ The key is not meant to be exposed to the monad, so it is only held - -- within the closure that signs a given transaction. - -- It is recommended to use 'signGYTxBody' and similar to implement this method. - signTxBody :: GYTxBody -> m GYTx - - -- | Sign a transaction body with the user payment key AND user stake key to produce - -- a transaction with witnesses. - -- If the user wallet does not have a stake key, this function should be equivalent to - -- 'signTxBody'. - -- - -- See note on 'signTxBody' - signTxBodyWithStake :: GYTxBody -> m GYTx - - -- | Submit a fully built transaction to the chain. - -- Use 'buildTxBody' to build a transaction body, and 'signGYTxBody' to - -- sign it before submitting. - -- - -- /Note:/ Changes made to the chain by the submitted transaction may not be reflected immediately, - -- see 'awaitTxConfirmed'. - -- - -- /Law:/ 'someUTxO' calls made after a call to 'submitTx' may return previously returned UTxOs - -- if they were not affected by the submitted transaction. - submitTx :: GYTx -> m GYTxId - - -- | Wait for a _recently_ submitted transaction to be confirmed. - -- - -- /Note:/ If used on a transaction submitted long ago, the behavior is undefined. - -- - -- /Law:/ Queries made after a call to 'awaitTxConfirmed'' should reflect changes made to the chain - -- by the identified transaction. - awaitTxConfirmed' :: GYAwaitTxParameters -> GYTxId -> m () - -signTxBodyImpl :: GYTxMonad m => m GYPaymentSigningKey -> GYTxBody -> m GYTx -signTxBodyImpl kM txBody = signGYTxBody txBody . (:[]) <$> kM - -signTxBodyWithStakeImpl :: GYTxMonad m => m (GYPaymentSigningKey, Maybe GYStakeSigningKey) -> GYTxBody -> m GYTx +class (GYTxBuilderMonad m) => GYTxMonad m where + -- | Sign a transaction body with the user payment key to produce a transaction with witnesses. + -- + -- /Note:/ The key is not meant to be exposed to the monad, so it is only held + -- within the closure that signs a given transaction. + -- It is recommended to use 'signGYTxBody' and similar to implement this method. + signTxBody :: GYTxBody -> m GYTx + + -- | Sign a transaction body with the user payment key AND user stake key to produce + -- a transaction with witnesses. + -- If the user wallet does not have a stake key, this function should be equivalent to + -- 'signTxBody'. + -- + -- See note on 'signTxBody' + signTxBodyWithStake :: GYTxBody -> m GYTx + + -- | Submit a fully built transaction to the chain. + -- Use 'buildTxBody' to build a transaction body, and 'signGYTxBody' to + -- sign it before submitting. + -- + -- /Note:/ Changes made to the chain by the submitted transaction may not be reflected immediately, + -- see 'awaitTxConfirmed'. + -- + -- /Law:/ 'someUTxO' calls made after a call to 'submitTx' may return previously returned UTxOs + -- if they were not affected by the submitted transaction. + submitTx :: GYTx -> m GYTxId + + -- | Wait for a _recently_ submitted transaction to be confirmed. + -- + -- /Note:/ If used on a transaction submitted long ago, the behavior is undefined. + -- + -- /Law:/ Queries made after a call to 'awaitTxConfirmed'' should reflect changes made to the chain + -- by the identified transaction. + awaitTxConfirmed' :: GYAwaitTxParameters -> GYTxId -> m () + +signTxBodyImpl :: (GYTxMonad m) => m GYPaymentSigningKey -> GYTxBody -> m GYTx +signTxBodyImpl kM txBody = signGYTxBody txBody . (: []) <$> kM + +signTxBodyWithStakeImpl :: (GYTxMonad m) => m (GYPaymentSigningKey, Maybe GYStakeSigningKey) -> GYTxBody -> m GYTx signTxBodyWithStakeImpl kM txBody = (\(pKey, sKey) -> signGYTxBody txBody $ GYSomeSigningKey pKey : maybeToList (GYSomeSigningKey <$> sKey)) <$> kM -- | Class of monads that can simulate a "game" between different users interacting with transactions. class (GYTxMonad (TxMonadOf m), GYTxSpecialQueryMonad m) => GYTxGameMonad m where - -- | Type of the supported 'GYTxMonad' instance that can participate within the "game". - type TxMonadOf m = (r :: Type -> Type) | r -> m - -- TODO: Maybe introduce a user generation config type that this function can take? - {- | Create a new user within the chain. This does not fund the user. See "GeniusYield.Test.Utils.createUserWithLovelace" - or "GeniusYield.Test.Utils.createUserWithAssets". - - This _must not_ fund the user. - Note: The generated user may be arbitrarily complex. i.e may have zero or more stake keys (and thus one or more addresses). - -} - createUser :: m User - -- | Lift the supported 'GYTxMonad' instance into the game, as a participating user wallet. - asUser :: User -> TxMonadOf m a -> m a + -- | Type of the supported 'GYTxMonad' instance that can participate within the "game". + type TxMonadOf m = (r :: Type -> Type) | r -> m + + -- TODO: Maybe introduce a user generation config type that this function can take? + + -- | Create a new user within the chain. This does not fund the user. See "GeniusYield.Test.Utils.createUserWithLovelace" + -- or "GeniusYield.Test.Utils.createUserWithAssets". + -- + -- This _must not_ fund the user. + -- Note: The generated user may be arbitrarily complex. i.e may have zero or more stake keys (and thus one or more addresses). + createUser :: m User + + -- | Lift the supported 'GYTxMonad' instance into the game, as a participating user wallet. + asUser :: User -> TxMonadOf m a -> m a {- Note [Higher order effects, TxMonadOf, and GYTxGameMonad] @@ -276,55 +288,56 @@ will be automatically inferred. -} -- | > waitUntilSlot_ = void . waitUntilSlot -waitUntilSlot_ :: GYTxQueryMonad m => GYSlot -> m () +waitUntilSlot_ :: (GYTxQueryMonad m) => GYSlot -> m () waitUntilSlot_ = void . waitUntilSlot -- | Wait until the chain tip has progressed by N slots. -waitNSlots :: GYTxQueryMonad m => Word64 -> m GYSlot +waitNSlots :: (GYTxQueryMonad m) => Word64 -> m GYSlot waitNSlots (slotFromWord64 -> n) = do - -- FIXME: Does this need to be an absolute slot getter instead? - currentSlot <- slotOfCurrentBlock - waitUntilSlot . slotFromApi $ currentSlot `addSlots` n + -- FIXME: Does this need to be an absolute slot getter instead? + currentSlot <- slotOfCurrentBlock + waitUntilSlot . slotFromApi $ currentSlot `addSlots` n where addSlots = (+) `on` slotToApi -- | > waitNSlots_ = void . waitNSlots -waitNSlots_ :: GYTxQueryMonad m => Word64 -> m () +waitNSlots_ :: (GYTxQueryMonad m) => Word64 -> m () waitNSlots_ = void . waitNSlots -- | > submitTx_ = void . submitTx -submitTx_ :: GYTxMonad m => GYTx -> m () +submitTx_ :: (GYTxMonad m) => GYTx -> m () submitTx_ = void . submitTx -- | > submitTxConfirmed_ = void . submitTxConfirmed -submitTxConfirmed_ :: GYTxMonad m => GYTx -> m () +submitTxConfirmed_ :: (GYTxMonad m) => GYTx -> m () submitTxConfirmed_ = void . submitTxConfirmed -- | 'submitTxConfirmed'' with default tx waiting parameters. -submitTxConfirmed :: GYTxMonad m => GYTx -> m GYTxId +submitTxConfirmed :: (GYTxMonad m) => GYTx -> m GYTxId submitTxConfirmed = submitTxConfirmed' def -- | > submitTxConfirmed'_ p = void . submitTxConfirmed' p -submitTxConfirmed'_ :: GYTxMonad m => GYAwaitTxParameters -> GYTx -> m () +submitTxConfirmed'_ :: (GYTxMonad m) => GYAwaitTxParameters -> GYTx -> m () submitTxConfirmed'_ awaitParams = void . submitTxConfirmed' awaitParams -- | Equivalent to a call to 'submitTx' and then a call to 'awaitTxConfirmed'' with submitted tx id. -submitTxConfirmed' :: GYTxMonad m => GYAwaitTxParameters -> GYTx -> m GYTxId +submitTxConfirmed' :: (GYTxMonad m) => GYAwaitTxParameters -> GYTx -> m GYTxId submitTxConfirmed' awaitParams tx = do - txId <- submitTx tx - awaitTxConfirmed' awaitParams txId - pure txId + txId <- submitTx tx + awaitTxConfirmed' awaitParams txId + pure txId -- | Wait for a _recently_ submitted transaction to be confirmed, with default waiting parameters. -awaitTxConfirmed :: GYTxMonad m => GYTxId -> m () +awaitTxConfirmed :: (GYTxMonad m) => GYTxId -> m () awaitTxConfirmed = awaitTxConfirmed' def -- | > submitTxBody_ t = void . submitTxBody t submitTxBody_ :: forall a m. (GYTxMonad m, ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> m () submitTxBody_ txBody = void . submitTxBody txBody --- | Signs a 'GYTxBody' with the given keys and submits the transaction. --- Equivalent to a call to 'signGYTxBody', followed by a call to 'submitTx' +{- | Signs a 'GYTxBody' with the given keys and submits the transaction. +Equivalent to a call to 'signGYTxBody', followed by a call to 'submitTx' +-} submitTxBody :: forall a m. (GYTxMonad m, ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> m GYTxId submitTxBody txBody = submitTx . signGYTxBody txBody @@ -332,15 +345,16 @@ submitTxBody txBody = submitTx . signGYTxBody txBody submitTxBodyConfirmed_ :: (GYTxMonad m, ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> m () submitTxBodyConfirmed_ txBody = void . submitTxBodyConfirmed txBody --- | Signs a 'GYTxBody' with the given keys, submits the transaction, and waits for its confirmation. --- Equivalent to a call to 'signGYTxBody', followed by a call to 'submitTxConfirmed'. -submitTxBodyConfirmed :: forall a m. (GYTxMonad m, ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> m GYTxId +{- | Signs a 'GYTxBody' with the given keys, submits the transaction, and waits for its confirmation. +Equivalent to a call to 'signGYTxBody', followed by a call to 'submitTxConfirmed'. +-} +submitTxBodyConfirmed :: forall a m. (GYTxMonad m, ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> m GYTxId submitTxBodyConfirmed txBody = submitTxConfirmed . signGYTxBody txBody -signAndSubmitConfirmed_ :: GYTxMonad m => GYTxBody -> m () +signAndSubmitConfirmed_ :: (GYTxMonad m) => GYTxBody -> m () signAndSubmitConfirmed_ = void . signAndSubmitConfirmed -signAndSubmitConfirmed :: GYTxMonad m => GYTxBody -> m GYTxId +signAndSubmitConfirmed :: (GYTxMonad m) => GYTxBody -> m GYTxId signAndSubmitConfirmed txBody = signTxBody txBody >>= submitTxConfirmed ------------------------------------------------------------------------------- @@ -367,29 +381,29 @@ Since these wrapper data types are usage specific, and 'GYTxGameMonad' instances "overarching base" type, we do not provide these instances and users may define them if necessary. -} -instance GYTxBuilderMonad m => GYTxBuilderMonad (RandT g m) where - type TxBuilderStrategy (RandT g m) = TxBuilderStrategy m - buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x - buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x - buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x - -instance GYTxMonad m => GYTxMonad (RandT g m) where - signTxBody = lift . signTxBody - signTxBodyWithStake = lift . signTxBodyWithStake - submitTx = lift . submitTx - awaitTxConfirmed' p = lift . awaitTxConfirmed' p - -instance GYTxBuilderMonad m => GYTxBuilderMonad (ReaderT env m) where - type TxBuilderStrategy (ReaderT env m) = TxBuilderStrategy m - buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x - buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x - buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x - -instance GYTxMonad m => GYTxMonad (ReaderT env m) where - signTxBody = lift . signTxBody - signTxBodyWithStake = lift . signTxBodyWithStake - submitTx = lift . submitTx - awaitTxConfirmed' p = lift . awaitTxConfirmed' p +instance (GYTxBuilderMonad m) => GYTxBuilderMonad (RandT g m) where + type TxBuilderStrategy (RandT g m) = TxBuilderStrategy m + buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x + buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x + buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x + +instance (GYTxMonad m) => GYTxMonad (RandT g m) where + signTxBody = lift . signTxBody + signTxBodyWithStake = lift . signTxBodyWithStake + submitTx = lift . submitTx + awaitTxConfirmed' p = lift . awaitTxConfirmed' p + +instance (GYTxBuilderMonad m) => GYTxBuilderMonad (ReaderT env m) where + type TxBuilderStrategy (ReaderT env m) = TxBuilderStrategy m + buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x + buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x + buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x + +instance (GYTxMonad m) => GYTxMonad (ReaderT env m) where + signTxBody = lift . signTxBody + signTxBodyWithStake = lift . signTxBodyWithStake + submitTx = lift . submitTx + awaitTxConfirmed' p = lift . awaitTxConfirmed' p ------------------------------------------------------------------------------- -- Instances for less useful transformers, provided for completeness. @@ -397,279 +411,309 @@ instance GYTxMonad m => GYTxMonad (ReaderT env m) where -- See: https://github.com/haskell-effectful/effectful/blob/master/transformers.md ------------------------------------------------------------------------------- -instance GYTxBuilderMonad m => GYTxBuilderMonad (Strict.StateT s m) where - type TxBuilderStrategy (Strict.StateT s m) = TxBuilderStrategy m - buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x - buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x - buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x - -instance GYTxMonad m => GYTxMonad (Strict.StateT s m) where - signTxBody = lift . signTxBody - signTxBodyWithStake = lift . signTxBodyWithStake - submitTx = lift . submitTx - awaitTxConfirmed' p = lift . awaitTxConfirmed' p - -instance GYTxBuilderMonad m => GYTxBuilderMonad (Lazy.StateT s m) where - type TxBuilderStrategy (Lazy.StateT s m) = TxBuilderStrategy m - buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x - buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x - buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x - -instance GYTxMonad m => GYTxMonad (Lazy.StateT s m) where - signTxBody = lift . signTxBody - signTxBodyWithStake = lift . signTxBodyWithStake - submitTx = lift . submitTx - awaitTxConfirmed' p = lift . awaitTxConfirmed' p +instance (GYTxBuilderMonad m) => GYTxBuilderMonad (Strict.StateT s m) where + type TxBuilderStrategy (Strict.StateT s m) = TxBuilderStrategy m + buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x + buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x + buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x + +instance (GYTxMonad m) => GYTxMonad (Strict.StateT s m) where + signTxBody = lift . signTxBody + signTxBodyWithStake = lift . signTxBodyWithStake + submitTx = lift . submitTx + awaitTxConfirmed' p = lift . awaitTxConfirmed' p + +instance (GYTxBuilderMonad m) => GYTxBuilderMonad (Lazy.StateT s m) where + type TxBuilderStrategy (Lazy.StateT s m) = TxBuilderStrategy m + buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x + buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x + buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x + +instance (GYTxMonad m) => GYTxMonad (Lazy.StateT s m) where + signTxBody = lift . signTxBody + signTxBodyWithStake = lift . signTxBodyWithStake + submitTx = lift . submitTx + awaitTxConfirmed' p = lift . awaitTxConfirmed' p instance (GYTxBuilderMonad m, Monoid w) => GYTxBuilderMonad (CPS.WriterT w m) where - type TxBuilderStrategy (CPS.WriterT w m) = TxBuilderStrategy m - buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x - buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x - buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x + type TxBuilderStrategy (CPS.WriterT w m) = TxBuilderStrategy m + buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x + buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x + buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x instance (GYTxMonad m, Monoid w) => GYTxMonad (CPS.WriterT w m) where - signTxBody = lift . signTxBody - signTxBodyWithStake = lift . signTxBodyWithStake - submitTx = lift . submitTx - awaitTxConfirmed' p = lift . awaitTxConfirmed' p + signTxBody = lift . signTxBody + signTxBodyWithStake = lift . signTxBodyWithStake + submitTx = lift . submitTx + awaitTxConfirmed' p = lift . awaitTxConfirmed' p instance (GYTxBuilderMonad m, Monoid w) => GYTxBuilderMonad (Strict.WriterT w m) where - type TxBuilderStrategy (Strict.WriterT w m) = TxBuilderStrategy m - buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x - buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x - buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x + type TxBuilderStrategy (Strict.WriterT w m) = TxBuilderStrategy m + buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x + buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x + buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x instance (GYTxMonad m, Monoid w) => GYTxMonad (Strict.WriterT w m) where - signTxBody = lift . signTxBody - signTxBodyWithStake = lift . signTxBodyWithStake - submitTx = lift . submitTx - awaitTxConfirmed' p = lift . awaitTxConfirmed' p + signTxBody = lift . signTxBody + signTxBodyWithStake = lift . signTxBodyWithStake + submitTx = lift . submitTx + awaitTxConfirmed' p = lift . awaitTxConfirmed' p instance (GYTxBuilderMonad m, Monoid w) => GYTxBuilderMonad (Lazy.WriterT w m) where - type TxBuilderStrategy (Lazy.WriterT w m) = TxBuilderStrategy m - buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x - buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x - buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x + type TxBuilderStrategy (Lazy.WriterT w m) = TxBuilderStrategy m + buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x + buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x + buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x instance (GYTxMonad m, Monoid w) => GYTxMonad (Lazy.WriterT w m) where - signTxBody = lift . signTxBody - signTxBodyWithStake = lift . signTxBodyWithStake - submitTx = lift . submitTx - awaitTxConfirmed' p = lift . awaitTxConfirmed' p + signTxBody = lift . signTxBody + signTxBodyWithStake = lift . signTxBodyWithStake + submitTx = lift . submitTx + awaitTxConfirmed' p = lift . awaitTxConfirmed' p -- | A version of 'lookupDatum' that raises 'GYNoDatumForHash' if the datum is not found. -lookupDatum' :: GYTxQueryMonad m => GYDatumHash -> m GYDatum +lookupDatum' :: (GYTxQueryMonad m) => GYDatumHash -> m GYDatum lookupDatum' h = lookupDatum h >>= maybe (throwError . GYQueryDatumException $ GYNoDatumForHash h) pure -- | A version of 'utxoAtTxOutRef' that raises 'GYNoUtxoAtRef' if the utxo is not found. -utxoAtTxOutRef' :: GYTxQueryMonad m => GYTxOutRef -> m GYUTxO -utxoAtTxOutRef' ref = utxoAtTxOutRef ref +utxoAtTxOutRef' :: (GYTxQueryMonad m) => GYTxOutRef -> m GYUTxO +utxoAtTxOutRef' ref = + utxoAtTxOutRef ref >>= maybe - (throwError . GYQueryUTxOException $ GYNoUtxoAtRef ref) - pure + (throwError . GYQueryUTxOException $ GYNoUtxoAtRef ref) + pure -- | A version of 'utxoAtTxOutRefWithDatum' that raises 'GYNoUtxoAtRef' if the utxo is not found. -utxoAtTxOutRefWithDatum' :: GYTxQueryMonad m => GYTxOutRef -> m (GYUTxO, Maybe GYDatum) -utxoAtTxOutRefWithDatum' ref = utxoAtTxOutRefWithDatum ref +utxoAtTxOutRefWithDatum' :: (GYTxQueryMonad m) => GYTxOutRef -> m (GYUTxO, Maybe GYDatum) +utxoAtTxOutRefWithDatum' ref = + utxoAtTxOutRefWithDatum ref >>= maybe - (throwError . GYQueryUTxOException $ GYNoUtxoAtRef ref) - pure + (throwError . GYQueryUTxOException $ GYNoUtxoAtRef ref) + pure -- | Returns some UTxO present in wallet which doesn't have reference script. -someUTxOWithoutRefScript :: GYTxUserQueryMonad m => m GYTxOutRef +someUTxOWithoutRefScript :: (GYTxUserQueryMonad m) => m GYTxOutRef someUTxOWithoutRefScript = do utxosToConsider <- utxosRemoveRefScripts <$> availableUTxOs - addrs <- ownAddresses + addrs <- ownAddresses case someTxOutRef utxosToConsider of Just (oref, _) -> return oref - Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Possible to put better error message here? - + Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Possible to put better error message here? ------------------------------------------------------------------------------- -- Slot <-> Time conversion functions within the monad ------------------------------------------------------------------------------- -- | Get the starting 'GYTime' of a 'GYSlot' in 'GYTxMonad'. -slotToBeginTime :: GYTxQueryMonad f => GYSlot -> f GYTime +slotToBeginTime :: (GYTxQueryMonad f) => GYSlot -> f GYTime slotToBeginTime x = flip slotToBeginTimePure x <$> slotConfig -- | Get the ending 'GYTime' of a 'GYSlot' (inclusive) in 'GYTxMonad'. -slotToEndTime :: GYTxQueryMonad f => GYSlot -> f GYTime +slotToEndTime :: (GYTxQueryMonad f) => GYSlot -> f GYTime slotToEndTime x = flip slotToEndTimePure x <$> slotConfig {- | Get the 'GYSlot' of a 'GYTime' in 'GYTxMonad'. Returns 'Nothing' if given time is before known system start. -} -enclosingSlotFromTime :: GYTxQueryMonad f => GYTime -> f (Maybe GYSlot) +enclosingSlotFromTime :: (GYTxQueryMonad f) => GYTime -> f (Maybe GYSlot) enclosingSlotFromTime x = flip enclosingSlotFromTimePure x <$> slotConfig {- | Partial version of 'enclosingSlotFromTime'. Raises 'GYTimeUnderflowException' if given time is before known system start. -} -enclosingSlotFromTime' :: GYTxQueryMonad m => GYTime -> m GYSlot +enclosingSlotFromTime' :: (GYTxQueryMonad m) => GYTime -> m GYSlot enclosingSlotFromTime' x = do - sysStart <- gyscSystemStart <$> slotConfig - enclosingSlotFromTime x >>= maybe (throwError $ GYTimeUnderflowException sysStart x) pure + sysStart <- gyscSystemStart <$> slotConfig + enclosingSlotFromTime x >>= maybe (throwError $ GYTimeUnderflowException sysStart x) pure ------------------------------------------------------------------------------- -- Utilities ------------------------------------------------------------------------------- -- | Calculate script's address. -scriptAddress :: GYTxQueryMonad m => GYValidator v -> m GYAddress +scriptAddress :: (GYTxQueryMonad m) => GYValidator v -> m GYAddress scriptAddress v = do - nid <- networkId - return $ addressFromValidator nid v + nid <- networkId + return $ addressFromValidator nid v -- | Calculate script's address. -scriptAddress' :: GYTxQueryMonad m => GYValidatorHash -> m GYAddress +scriptAddress' :: (GYTxQueryMonad m) => GYValidatorHash -> m GYAddress scriptAddress' h = do - nid <- networkId - return $ addressFromValidatorHash nid h + nid <- networkId + return $ addressFromValidatorHash nid h --- | Convert a 'Plutus.Address' to 'GYAddress' in 'GYTxMonad'. --- --- Explicitly returns an error rather than throwing it. -addressFromPlutusM :: GYTxQueryMonad m => Plutus.Address -> m (Either PlutusToCardanoError GYAddress) +{- | Convert a 'Plutus.Address' to 'GYAddress' in 'GYTxMonad'. + +Explicitly returns an error rather than throwing it. +-} +addressFromPlutusM :: (GYTxQueryMonad m) => Plutus.Address -> m (Either PlutusToCardanoError GYAddress) addressFromPlutusM addr = flip addressFromPlutus addr <$> networkId -- | 'hush'ed version of 'addressFromPlutusM'. -addressFromPlutusHushedM :: GYTxQueryMonad m => Plutus.Address -> m (Maybe GYAddress) +addressFromPlutusHushedM :: (GYTxQueryMonad m) => Plutus.Address -> m (Maybe GYAddress) addressFromPlutusHushedM addr = fmap hush $ flip addressFromPlutus addr <$> networkId --- | Convert a 'Plutus.Address' to 'GYAddress' in 'GYTxMonad'. --- --- Throw 'GYConversionException' if conversion fails. -addressFromPlutus' :: GYTxQueryMonad m => Plutus.Address -> m GYAddress +{- | Convert a 'Plutus.Address' to 'GYAddress' in 'GYTxMonad'. + +Throw 'GYConversionException' if conversion fails. +-} +addressFromPlutus' :: (GYTxQueryMonad m) => Plutus.Address -> m GYAddress addressFromPlutus' addr = do - x <- addressFromPlutusM addr - liftEither $ first (GYConversionException . GYLedgerToCardanoError) x - --- | Convert 'GYAddress' to 'GYPubKeyHash' in 'GYTxMonad'. --- --- Throw 'GYConversionException' if address is not key-hash one. -addressToPubKeyHash' :: MonadError GYTxMonadException m => GYAddress -> m GYPubKeyHash -addressToPubKeyHash' addr = maybe + x <- addressFromPlutusM addr + liftEither $ first (GYConversionException . GYLedgerToCardanoError) x + +{- | Convert 'GYAddress' to 'GYPubKeyHash' in 'GYTxMonad'. + +Throw 'GYConversionException' if address is not key-hash one. +-} +addressToPubKeyHash' :: (MonadError GYTxMonadException m) => GYAddress -> m GYPubKeyHash +addressToPubKeyHash' addr = + maybe (throwError . GYConversionException $ GYNotPubKeyAddress addr) pure (addressToPubKeyHash addr) addressToPubKeyHashIO :: GYAddress -> IO GYPubKeyHash -addressToPubKeyHashIO addr = maybe +addressToPubKeyHashIO addr = + maybe (throwIO . GYConversionException $ GYNotPubKeyAddress addr) pure (addressToPubKeyHash addr) --- | Convert 'GYAddress' to 'GYValidatorHash' in 'GYTxMonad'. --- --- Throw 'GYConversionException' if address is not script-hash one. -addressToValidatorHash' :: MonadError GYTxMonadException m => GYAddress -> m GYValidatorHash -addressToValidatorHash' addr = maybe +{- | Convert 'GYAddress' to 'GYValidatorHash' in 'GYTxMonad'. + +Throw 'GYConversionException' if address is not script-hash one. +-} +addressToValidatorHash' :: (MonadError GYTxMonadException m) => GYAddress -> m GYValidatorHash +addressToValidatorHash' addr = + maybe (throwError . GYConversionException $ GYNotPubKeyAddress addr) pure (addressToValidatorHash addr) addressToValidatorHashIO :: GYAddress -> IO GYValidatorHash -addressToValidatorHashIO addr = maybe +addressToValidatorHashIO addr = + maybe (throwIO . GYConversionException $ GYNotScriptAddress addr) pure (addressToValidatorHash addr) --- | Convert a 'Plutus.Value' to 'GYValue' in 'GYTxMonad'. --- --- Throw 'GYConversionException' if conversion fails. -valueFromPlutus' :: MonadError GYTxMonadException m => Plutus.Value -> m GYValue -valueFromPlutus' val = either +{- | Convert a 'Plutus.Value' to 'GYValue' in 'GYTxMonad'. + +Throw 'GYConversionException' if conversion fails. +-} +valueFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.Value -> m GYValue +valueFromPlutus' val = + either (throwError . GYConversionException . flip GYInvalidPlutusValue val) pure (valueFromPlutus val) --- | Convert a 'Plutus.Value' to 'GYValue' in 'IO'. --- --- Throw 'GYConversionException' if conversion fails. +{- | Convert a 'Plutus.Value' to 'GYValue' in 'IO'. + +Throw 'GYConversionException' if conversion fails. +-} valueFromPlutusIO :: Plutus.Value -> IO GYValue -valueFromPlutusIO val = either +valueFromPlutusIO val = + either (throwIO . GYConversionException . flip GYInvalidPlutusValue val) pure (valueFromPlutus val) --- | Create a 'GYAssetClass' from the textual representation of currency symbol and token name in 'GYTxMonad'. --- --- Throw 'GYConversionException' if conversion fails. -makeAssetClass' :: MonadError GYTxMonadException m => Text -> Text -> m GYAssetClass -makeAssetClass' a b = either +{- | Create a 'GYAssetClass' from the textual representation of currency symbol and token name in 'GYTxMonad'. + +Throw 'GYConversionException' if conversion fails. +-} +makeAssetClass' :: (MonadError GYTxMonadException m) => Text -> Text -> m GYAssetClass +makeAssetClass' a b = + either (throwError . GYConversionException . GYInvalidAssetClass . Txt.pack) pure (makeAssetClass a b) --- | 'makeAssetClass'' in the IO monad. --- --- Throw 'GYConversionException' if conversion fails. +{- | 'makeAssetClass'' in the IO monad. + +Throw 'GYConversionException' if conversion fails. +-} makeAssetClassIO :: Text -> Text -> IO GYAssetClass -makeAssetClassIO a b = either +makeAssetClassIO a b = + either (throwIO . GYConversionException . GYInvalidAssetClass . Txt.pack) pure (makeAssetClass a b) --- | Convert a 'Plutus.AssetClass' to 'GYAssetClass' in 'GYTxMonad'. --- --- Throw 'GYConversionException' if conversion fails. -assetClassFromPlutus' :: MonadError GYTxMonadException m => Plutus.AssetClass -> m GYAssetClass -assetClassFromPlutus' x = either +{- | Convert a 'Plutus.AssetClass' to 'GYAssetClass' in 'GYTxMonad'. + +Throw 'GYConversionException' if conversion fails. +-} +assetClassFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.AssetClass -> m GYAssetClass +assetClassFromPlutus' x = + either (throwError . GYConversionException . GYInvalidPlutusAsset) pure (assetClassFromPlutus x) --- | Convert a 'PlutusValue.TokenName' to 'GYTokenName' in 'GYTxMonad'. --- --- Throw 'GYConversionException' if conversion fails. -tokenNameFromPlutus' :: MonadError GYTxMonadException m => Plutus.TokenName -> m GYTokenName -tokenNameFromPlutus' x = maybe +{- | Convert a 'PlutusValue.TokenName' to 'GYTokenName' in 'GYTxMonad'. + +Throw 'GYConversionException' if conversion fails. +-} +tokenNameFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.TokenName -> m GYTokenName +tokenNameFromPlutus' x = + maybe (throwError . GYConversionException . GYInvalidPlutusAsset $ GYTokenNameTooBig x) pure (tokenNameFromPlutus x) --- | Convert a 'Plutus.TxOutRef' to 'GYTxOutRef' in 'GYTxMonad'. --- --- Throw 'GYConversionException' if conversion fails. -txOutRefFromPlutus' :: MonadError GYTxMonadException m => Plutus.TxOutRef -> m GYTxOutRef -txOutRefFromPlutus' ref = either +{- | Convert a 'Plutus.TxOutRef' to 'GYTxOutRef' in 'GYTxMonad'. + +Throw 'GYConversionException' if conversion fails. +-} +txOutRefFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.TxOutRef -> m GYTxOutRef +txOutRefFromPlutus' ref = + either (throwError . GYConversionException . GYLedgerToCardanoError) pure (txOutRefFromPlutus ref) --- | Convert a 'Plutus.DatumHash' to 'GYDatumHash' in 'GYTxMonad'. --- --- Throw 'GYConversionException' if conversion fails. -datumHashFromPlutus' :: MonadError GYTxMonadException m => Plutus.DatumHash -> m GYDatumHash -datumHashFromPlutus' dh = either +{- | Convert a 'Plutus.DatumHash' to 'GYDatumHash' in 'GYTxMonad'. + +Throw 'GYConversionException' if conversion fails. +-} +datumHashFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.DatumHash -> m GYDatumHash +datumHashFromPlutus' dh = + either (throwError . GYConversionException . GYLedgerToCardanoError) pure (datumHashFromPlutus dh) --- | Convert a 'Plutus.PubKeyHash' to 'GYPubKeyHash' in 'GYTxMonad'. --- --- Throw 'GYConversionException' if conversion fails. -pubKeyHashFromPlutus' :: MonadError GYTxMonadException m => Plutus.PubKeyHash -> m GYPubKeyHash -pubKeyHashFromPlutus' pkh = either +{- | Convert a 'Plutus.PubKeyHash' to 'GYPubKeyHash' in 'GYTxMonad'. + +Throw 'GYConversionException' if conversion fails. +-} +pubKeyHashFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.PubKeyHash -> m GYPubKeyHash +pubKeyHashFromPlutus' pkh = + either (throwError . GYConversionException . GYLedgerToCardanoError) pure (pubKeyHashFromPlutus pkh) --- | Parse the bech32 representation of an address into 'GYAddress' in 'GYTxMonad'. --- --- Throw 'GYConversionException' if parsing fails. -addressFromText' :: MonadError GYTxMonadException m => Text -> m GYAddress -addressFromText' addr = maybe +{- | Parse the bech32 representation of an address into 'GYAddress' in 'GYTxMonad'. + +Throw 'GYConversionException' if parsing fails. +-} +addressFromText' :: (MonadError GYTxMonadException m) => Text -> m GYAddress +addressFromText' addr = + maybe (throwError . GYConversionException $ GYInvalidAddressText addr) pure (addressFromTextMaybe addr) -- | Advance 'GYSlot' forward in 'GYTxMonad'. If slot value overflows, throw 'GYSlotOverflowException'. -advanceSlot' :: MonadError GYTxMonadException m => GYSlot -> Natural -> m GYSlot -advanceSlot' s t = maybe +advanceSlot' :: (MonadError GYTxMonadException m) => GYSlot -> Natural -> m GYSlot +advanceSlot' s t = + maybe (throwError $ GYSlotOverflowException s t) pure (advanceSlot s t) @@ -678,72 +722,72 @@ utxosDatums :: forall m a. (GYTxQueryMonad m, Plutus.FromData a) => GYUTxOs -> m utxosDatums = witherUTxOs utxoDatumHushed -- | Pure variant of `utxosDatums`. -utxosDatumsPure :: Plutus.FromData a => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a) +utxosDatumsPure :: (Plutus.FromData a) => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a) utxosDatumsPure = Map.fromList . mapMaybe utxoDatumPureHushed -- | Like `utxosDatumsPure` but also returns original raw `GYDatum`. -utxosDatumsPureWithOriginalDatum :: Plutus.FromData a => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a, GYDatum) +utxosDatumsPureWithOriginalDatum :: (Plutus.FromData a) => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a, GYDatum) utxosDatumsPureWithOriginalDatum = Map.fromList . mapMaybe utxoDatumPureHushedWithOriginalDatum utxoDatum :: (GYTxQueryMonad m, Plutus.FromData a) => GYUTxO -> m (Either GYQueryDatumError (GYAddress, GYValue, a)) utxoDatum utxo = case utxoOutDatum utxo of - GYOutDatumNone -> pure . Left $ GYNoDatumHash utxo - GYOutDatumHash h -> do - md <- lookupDatum h - case md of - Nothing -> pure . Left $ GYNoDatumForHash h - Just d -> datumToRes d - GYOutDatumInline d -> datumToRes d + GYOutDatumNone -> pure . Left $ GYNoDatumHash utxo + GYOutDatumHash h -> do + md <- lookupDatum h + case md of + Nothing -> pure . Left $ GYNoDatumForHash h + Just d -> datumToRes d + GYOutDatumInline d -> datumToRes d where datumToRes x = case Plutus.fromBuiltinData $ datumToPlutus' x of - Nothing -> pure . Left $ GYInvalidDatum x - Just a -> pure $ Right (utxoAddress utxo, utxoValue utxo, a) + Nothing -> pure . Left $ GYInvalidDatum x + Just a -> pure $ Right (utxoAddress utxo, utxoValue utxo, a) -- | Obtain original datum representation of an UTxO. -utxoDatumPureHushed :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a)) +utxoDatumPureHushed :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a)) utxoDatumPureHushed (_utxo, Nothing) = Nothing utxoDatumPureHushed (GYUTxO {..}, Just d) = datumToPlutus' d & Plutus.fromBuiltinData <&> \d' -> (utxoRef, (utxoAddress, utxoValue, d')) -- | Like `utxoDatumPureHushed` but also returns original raw `GYDatum`. -utxoDatumPureHushedWithOriginalDatum :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a, GYDatum)) +utxoDatumPureHushedWithOriginalDatum :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a, GYDatum)) utxoDatumPureHushedWithOriginalDatum (_utxo, Nothing) = Nothing utxoDatumPureHushedWithOriginalDatum (GYUTxO {..}, Just d) = datumToPlutus' d & Plutus.fromBuiltinData <&> \d' -> (utxoRef, (utxoAddress, utxoValue, d', d)) -- | Pure variant of `utxoDatum`. -utxoDatumPure :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a) +utxoDatumPure :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a) utxoDatumPure (utxo, Nothing) = Left $ GYNoDatumHash utxo utxoDatumPure (GYUTxO {..}, Just d) = case Plutus.fromBuiltinData $ datumToPlutus' d of Nothing -> Left $ GYInvalidDatum d - Just a -> Right (utxoAddress, utxoValue, a) + Just a -> Right (utxoAddress, utxoValue, a) -- | Like `utxoDatumPure` but also returns original raw datum. -utxoDatumPureWithOriginalDatum :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a, GYDatum) +utxoDatumPureWithOriginalDatum :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a, GYDatum) utxoDatumPureWithOriginalDatum (utxo, Nothing) = Left $ GYNoDatumHash utxo utxoDatumPureWithOriginalDatum (GYUTxO {..}, Just d) = case Plutus.fromBuiltinData $ datumToPlutus' d of Nothing -> Left $ GYInvalidDatum d - Just a -> Right (utxoAddress, utxoValue, a, d) + Just a -> Right (utxoAddress, utxoValue, a, d) -- | Version of 'utxoDatum' that throws 'GYTxMonadException'. utxoDatum' :: (GYTxQueryMonad m, Plutus.FromData a) => GYUTxO -> m (GYAddress, GYValue, a) utxoDatum' utxo = do - x <- utxoDatum utxo - liftEither $ first GYQueryDatumException x + x <- utxoDatum utxo + liftEither $ first GYQueryDatumException x -- | Version of 'utxoDatumPure' that throws 'GYTxMonadException'. utxoDatumPure' :: (MonadError GYTxMonadException m, Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> m (GYAddress, GYValue, a) utxoDatumPure' utxoWithDatum = do - let x = utxoDatumPure utxoWithDatum - liftEither $ first GYQueryDatumException x + let x = utxoDatumPure utxoWithDatum + liftEither $ first GYQueryDatumException x -- | Like `utxoDatumPure'` but also returns original raw datum. utxoDatumPureWithOriginalDatum' :: (MonadError GYTxMonadException m, Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> m (GYAddress, GYValue, a, GYDatum) utxoDatumPureWithOriginalDatum' utxoWithDatum = do - let x = utxoDatumPureWithOriginalDatum utxoWithDatum - liftEither $ first GYQueryDatumException x + let x = utxoDatumPureWithOriginalDatum utxoWithDatum + liftEither $ first GYQueryDatumException x utxoDatumHushed :: (GYTxQueryMonad m, Plutus.FromData a) => GYUTxO -> m (Maybe (GYAddress, GYValue, a)) utxoDatumHushed = fmap hush . utxoDatum @@ -751,8 +795,8 @@ utxoDatumHushed = fmap hush . utxoDatum mustHaveInput :: GYTxIn v -> GYTxSkeleton v mustHaveInput i = emptyGYTxSkeleton {gytxIns = [i]} -mustHaveRefInput :: VersionIsGreaterOrEqual v 'PlutusV2 => GYTxOutRef -> GYTxSkeleton v -mustHaveRefInput i = emptyGYTxSkeleton { gytxRefIns = GYTxSkeletonRefIns (Set.singleton i) } +mustHaveRefInput :: (VersionIsGreaterOrEqual v 'PlutusV2) => GYTxOutRef -> GYTxSkeleton v +mustHaveRefInput i = emptyGYTxSkeleton {gytxRefIns = GYTxSkeletonRefIns (Set.singleton i)} mustHaveOutput :: GYTxOut v -> GYTxSkeleton v mustHaveOutput o = emptyGYTxSkeleton {gytxOuts = [o]} @@ -764,7 +808,7 @@ mustHaveTxMetadata :: Maybe GYTxMetadata -> GYTxSkeleton v mustHaveTxMetadata m = emptyGYTxSkeleton {gytxMetadata = m} mustMint :: GYMintScript v -> GYRedeemer -> GYTokenName -> Integer -> GYTxSkeleton v -mustMint _ _ _ 0 = mempty +mustMint _ _ _ 0 = mempty mustMint p r tn n = emptyGYTxSkeleton {gytxMint = Map.singleton p (Map.singleton tn n, r)} mustHaveWithdrawal :: GYTxWdrl v -> GYTxSkeleton v @@ -773,7 +817,7 @@ mustHaveWithdrawal w = mempty {gytxWdrls = [w]} mustHaveCertificate :: GYTxCert v -> GYTxSkeleton v mustHaveCertificate c = mempty {gytxCerts = [c]} -mustBeSignedBy :: CanSignTx a => a -> GYTxSkeleton v +mustBeSignedBy :: (CanSignTx a) => a -> GYTxSkeleton v mustBeSignedBy pkh = emptyGYTxSkeleton {gytxSigs = Set.singleton $ toPubKeyHash pkh} isInvalidBefore :: GYSlot -> GYTxSkeleton v @@ -783,32 +827,32 @@ isInvalidAfter :: GYSlot -> GYTxSkeleton v isInvalidAfter s = emptyGYTxSkeleton {gytxInvalidAfter = Just s} gyLogDebug', gyLogInfo', gyLogWarning', gyLogError' :: (GYTxQueryMonad m, HasCallStack) => GYLogNamespace -> String -> m () -gyLogDebug' ns = withFrozenCallStack $ logMsg ns GYDebug -gyLogInfo' ns = withFrozenCallStack $ logMsg ns GYInfo +gyLogDebug' ns = withFrozenCallStack $ logMsg ns GYDebug +gyLogInfo' ns = withFrozenCallStack $ logMsg ns GYInfo gyLogWarning' ns = withFrozenCallStack $ logMsg ns GYWarning -gyLogError' ns = withFrozenCallStack $ logMsg ns GYError +gyLogError' ns = withFrozenCallStack $ logMsg ns GYError -- | Given a skeleton, returns a list of reference to reference script UTxOs which are present as witness. skeletonToRefScriptsORefs :: GYTxSkeleton v -> [GYTxOutRef] -skeletonToRefScriptsORefs GYTxSkeleton{ gytxIns } = go gytxIns [] +skeletonToRefScriptsORefs GYTxSkeleton {gytxIns} = go gytxIns [] where go :: [GYTxIn v] -> [GYTxOutRef] -> [GYTxOutRef] go [] acc = acc go (gytxIn : rest) acc = case gyTxInWitness gytxIn of GYTxInWitnessScript gyInScript _ _ -> case gyInScript of - GYInReference oRef _ -> go rest (oRef : acc) - _anyOtherMatch -> go rest acc + GYInReference oRef _ -> go rest (oRef : acc) + _anyOtherMatch -> go rest acc _anyOtherMatch -> go rest acc -- | Log the time a particular monad action took. wrapReqWithTimeLog :: (GYTxQueryMonad m, MonadIO m) => String -> m a -> m a wrapReqWithTimeLog label m = do - start <- liftIO getCurrentTime - a <- m - end <- liftIO getCurrentTime - let dur = end `diffUTCTime` start - logMsg mempty GYDebug $ label <> " took " <> show dur - pure a + start <- liftIO getCurrentTime + a <- m + end <- liftIO getCurrentTime + let dur = end `diffUTCTime` start + logMsg mempty GYDebug $ label <> " took " <> show dur + pure a -- | Synonym of 'wrapReqWithTimeLog'. wt :: (GYTxQueryMonad m, MonadIO m) => String -> m a -> m a @@ -822,18 +866,20 @@ will end up using the same utxos across the different txs. Consider using 'buildTxBodyParallel' or 'buildTxBodyChaining' instead. -} -buildTxBodyWithStrategy' :: forall v m. (GYTxSpecialQueryMonad m, GYTxUserQueryMonad m, MonadRandom m) - => GYCoinSelectionStrategy - -> GYTxSkeleton v - -> m GYTxBody +buildTxBodyWithStrategy' :: + forall v m. + (GYTxSpecialQueryMonad m, GYTxUserQueryMonad m, MonadRandom m) => + GYCoinSelectionStrategy -> + GYTxSkeleton v -> + m GYTxBody buildTxBodyWithStrategy' cstrat m = do - x <- buildTxBodyCore (const id) cstrat [m] - case x of - GYTxBuildSuccess ne -> pure $ NE.head ne - GYTxBuildPartialSuccess be _ -> throwError . GYBuildTxException $ GYBuildTxBalancingError be - GYTxBuildFailure be -> throwError . GYBuildTxException $ GYBuildTxBalancingError be - -- We know there is precisely one input. - GYTxBuildNoInputs -> error "buildTxBodyWithStrategy': absurd" + x <- buildTxBodyCore (const id) cstrat [m] + case x of + GYTxBuildSuccess ne -> pure $ NE.head ne + GYTxBuildPartialSuccess be _ -> throwError . GYBuildTxException $ GYBuildTxBalancingError be + GYTxBuildFailure be -> throwError . GYBuildTxException $ GYBuildTxBalancingError be + -- We know there is precisely one input. + GYTxBuildNoInputs -> error "buildTxBodyWithStrategy': absurd" {- | A multi 'GYTxSkeleton' builder. @@ -843,12 +889,13 @@ transactions at once. This supports failure recovery by utilizing 'GYTxBuildResult'. -} -buildTxBodyParallelWithStrategy' :: (GYTxSpecialQueryMonad m, GYTxUserQueryMonad m, MonadRandom m) - => GYCoinSelectionStrategy - -> [GYTxSkeleton v] - -> m GYTxBuildResult +buildTxBodyParallelWithStrategy' :: + (GYTxSpecialQueryMonad m, GYTxUserQueryMonad m, MonadRandom m) => + GYCoinSelectionStrategy -> + [GYTxSkeleton v] -> + m GYTxBuildResult buildTxBodyParallelWithStrategy' cstrat m = do - buildTxBodyCore updateOwnUtxosParallel cstrat m + buildTxBodyCore updateOwnUtxosParallel cstrat m {- | A chaining 'GYTxSkeleton' builder. @@ -858,13 +905,14 @@ This supports failure recovery by utilizing 'GYTxBuildResult'. **EXPERIMENTAL** -} -buildTxBodyChainingWithStrategy' :: (GYTxSpecialQueryMonad m, GYTxUserQueryMonad m, MonadRandom m) - => GYCoinSelectionStrategy - -> [GYTxSkeleton v] - -> m GYTxBuildResult +buildTxBodyChainingWithStrategy' :: + (GYTxSpecialQueryMonad m, GYTxUserQueryMonad m, MonadRandom m) => + GYCoinSelectionStrategy -> + [GYTxSkeleton v] -> + m GYTxBuildResult buildTxBodyChainingWithStrategy' cstrat m = do - addrs <- ownAddresses - buildTxBodyCore (updateOwnUtxosChaining $ Set.fromList addrs) cstrat m + addrs <- ownAddresses + buildTxBodyCore (updateOwnUtxosChaining $ Set.fromList addrs) cstrat m {- | The core implementation of buildTxBody: Building 'GYTxBody's out of one or more 'GYTxSkeleton's. @@ -885,33 +933,36 @@ own wallet, for next 'GYTxSkeleton's (if any). The function recovers successfully built tx skeletons, in case the list contains several of them. See: 'GYTxBuildResult'. -} -buildTxBodyCore - :: forall v m. (GYTxSpecialQueryMonad m, GYTxUserQueryMonad m, MonadRandom m) - => (GYTxBody -> GYUTxOs -> GYUTxOs) -- ^ Function governing how to update UTxO set when building for multiple skeletons. - -> GYCoinSelectionStrategy -- ^ Coin selection strategy. - -> [GYTxSkeleton v] -- ^ Skeleton(s). - -> m GYTxBuildResult +buildTxBodyCore :: + forall v m. + (GYTxSpecialQueryMonad m, GYTxUserQueryMonad m, MonadRandom m) => + -- | Function governing how to update UTxO set when building for multiple skeletons. + (GYTxBody -> GYUTxOs -> GYUTxOs) -> + -- | Coin selection strategy. + GYCoinSelectionStrategy -> + -- | Skeleton(s). + [GYTxSkeleton v] -> + m GYTxBuildResult buildTxBodyCore ownUtxoUpdateF cstrat skeletons = do - logSkeletons skeletons - - -- Obtain constant parameters to be used across several 'GYTxBody' generations. - ss <- systemStart - eh <- eraHistory - pp <- protocolParams - ps <- stakePools - - collateral <- ownCollateral - addrs <- ownAddresses - change <- ownChangeAddress - - e <- buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change collateral skeletons - case e of - Left err -> throwError $ GYBuildTxException err - Right res -> pure res - - where - logSkeletons :: [GYTxSkeleton v] -> m () - logSkeletons = mapM_ (logMsg "buildTxBody" GYDebug . show) + logSkeletons skeletons + + -- Obtain constant parameters to be used across several 'GYTxBody' generations. + ss <- systemStart + eh <- eraHistory + pp <- protocolParams + ps <- stakePools + + collateral <- ownCollateral + addrs <- ownAddresses + change <- ownChangeAddress + + e <- buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change collateral skeletons + case e of + Left err -> throwError $ GYBuildTxException err + Right res -> pure res + where + logSkeletons :: [GYTxSkeleton v] -> m () + logSkeletons = mapM_ (logMsg "buildTxBody" GYDebug . show) -- | Update own utxo set by removing any utxos used up in the given tx. updateOwnUtxosParallel :: GYTxBody -> GYUTxOs -> GYUTxOs @@ -920,7 +971,8 @@ updateOwnUtxosParallel txBody = utxosRemoveTxOutRefs (Set.fromList txIns) txIns = txBodyTxIns txBody {- | Update own utxo set by removing any utxos used up in the given tx, -**and** adding newly created utxos addressed to own wallet. -} +**and** adding newly created utxos addressed to own wallet. +-} updateOwnUtxosChaining :: Set GYAddress -> GYTxBody -> GYUTxOs -> GYUTxOs updateOwnUtxosChaining ownAddrs txBody utxos = utxosRemoveTxOutRefs (Set.fromList txIns) utxos <> txOutsOwn where diff --git a/src/GeniusYield/TxBuilder/Common.hs b/src/GeniusYield/TxBuilder/Common.hs index 17a20500..22d19a7e 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -1,79 +1,81 @@ -{-| +{- | Module : GeniusYield.TxBuilder.Common Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.TxBuilder.Common - ( GYTxSkeleton (..) - , GYTxSkeletonRefIns (..) - , emptyGYTxSkeleton - , gyTxSkeletonRefInsToList - , gyTxSkeletonRefInsSet - , GYTxBuildResult (..) - , buildTxCore - , collateralLovelace - , collateralValue - , maximumRequiredCollateralLovelace - , maximumRequiredCollateralValue - ) where - -import qualified Cardano.Api as Api -import Cardano.Api.Ledger (unboundRational) -import qualified Cardano.Api.Ledger as Ledger -import qualified Cardano.Api.Shelley as Api.S -import qualified Cardano.Ledger.Alonzo.Core as Ledger -import qualified Cardano.Ledger.Conway.PParams as Ledger -import qualified Cardano.Ledger.Conway.Tx as Ledger -import qualified Cardano.Ledger.Plutus as Ledger -import Control.Applicative ((<|>)) -import Control.Lens ((^.)) -import Control.Monad.Except (MonadError (throwError)) -import Control.Monad.Random (MonadRandom) -import Data.List (nubBy) -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import Data.Ratio ((%)) -import qualified Data.Set as Set -import GeniusYield.Imports -import GeniusYield.Transaction -import GeniusYield.Transaction.Common (minimumUTxO, - utxoFromTxInDetailed) -import GeniusYield.TxBuilder.Errors -import GeniusYield.TxBuilder.Query.Class -import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) +module GeniusYield.TxBuilder.Common ( + GYTxSkeleton (..), + GYTxSkeletonRefIns (..), + emptyGYTxSkeleton, + gyTxSkeletonRefInsToList, + gyTxSkeletonRefInsSet, + GYTxBuildResult (..), + buildTxCore, + collateralLovelace, + collateralValue, + maximumRequiredCollateralLovelace, + maximumRequiredCollateralValue, +) where + +import Cardano.Api qualified as Api +import Cardano.Api.Ledger (unboundRational) +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Ledger.Alonzo.Core qualified as Ledger +import Cardano.Ledger.Conway.PParams qualified as Ledger +import Cardano.Ledger.Conway.Tx qualified as Ledger +import Cardano.Ledger.Plutus qualified as Ledger +import Control.Applicative ((<|>)) +import Control.Lens ((^.)) +import Control.Monad.Except (MonadError (throwError)) +import Control.Monad.Random (MonadRandom) +import Data.List (nubBy) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.Ratio ((%)) +import Data.Set qualified as Set +import GeniusYield.Imports +import GeniusYield.Transaction +import GeniusYield.Transaction.Common ( + minimumUTxO, + utxoFromTxInDetailed, + ) +import GeniusYield.TxBuilder.Errors +import GeniusYield.TxBuilder.Query.Class +import GeniusYield.Types +import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) ------------------------------------------------------------------------------- -- Transaction skeleton ------------------------------------------------------------------------------- --- | Transaction skeleton --- --- /Note:/ let's add fields as we need them. --- --- The parameter @v@ indicates the minimum version of scripts allowed --- as inputs. --- +{- | Transaction skeleton + +/Note:/ let's add fields as we need them. + +The parameter @v@ indicates the minimum version of scripts allowed +as inputs. +-} data GYTxSkeleton (v :: PlutusVersion) = GYTxSkeleton - { gytxIns :: ![GYTxIn v] - , gytxOuts :: ![GYTxOut v] - , gytxRefIns :: !(GYTxSkeletonRefIns v) - , gytxMint :: !(Map (GYMintScript v) (Map GYTokenName Integer, GYRedeemer)) - , gytxWdrls :: ![GYTxWdrl v] - , gytxSigs :: !(Set GYPubKeyHash) - , gytxCerts :: ![GYTxCert v] - , gytxInvalidBefore :: !(Maybe GYSlot) - , gytxInvalidAfter :: !(Maybe GYSlot) - , gytxMetadata :: !(Maybe GYTxMetadata) - } deriving Show + { gytxIns :: ![GYTxIn v] + , gytxOuts :: ![GYTxOut v] + , gytxRefIns :: !(GYTxSkeletonRefIns v) + , gytxMint :: !(Map (GYMintScript v) (Map GYTokenName Integer, GYRedeemer)) + , gytxWdrls :: ![GYTxWdrl v] + , gytxSigs :: !(Set GYPubKeyHash) + , gytxCerts :: ![GYTxCert v] + , gytxInvalidBefore :: !(Maybe GYSlot) + , gytxInvalidAfter :: !(Maybe GYSlot) + , gytxMetadata :: !(Maybe GYTxMetadata) + } + deriving (Show) data GYTxSkeletonRefIns :: PlutusVersion -> Type where - GYTxSkeletonRefIns :: VersionIsGreaterOrEqual v 'PlutusV2 => !(Set GYTxOutRef) -> GYTxSkeletonRefIns v - GYTxSkeletonNoRefIns :: GYTxSkeletonRefIns v + GYTxSkeletonRefIns :: (VersionIsGreaterOrEqual v 'PlutusV2) => !(Set GYTxOutRef) -> GYTxSkeletonRefIns v + GYTxSkeletonNoRefIns :: GYTxSkeletonRefIns v deriving instance Show (GYTxSkeletonRefIns v) deriving instance Eq (GYTxSkeletonRefIns v) @@ -83,61 +85,63 @@ gyTxSkeletonRefInsToList = Set.toList . gyTxSkeletonRefInsSet gyTxSkeletonRefInsSet :: GYTxSkeletonRefIns v -> Set GYTxOutRef gyTxSkeletonRefInsSet (GYTxSkeletonRefIns xs) = xs -gyTxSkeletonRefInsSet GYTxSkeletonNoRefIns = Set.empty +gyTxSkeletonRefInsSet GYTxSkeletonNoRefIns = Set.empty instance Semigroup (GYTxSkeletonRefIns v) where - GYTxSkeletonRefIns a <> GYTxSkeletonRefIns b = GYTxSkeletonRefIns (Set.union a b) - GYTxSkeletonRefIns a <> GYTxSkeletonNoRefIns = GYTxSkeletonRefIns a - GYTxSkeletonNoRefIns <> GYTxSkeletonRefIns b = GYTxSkeletonRefIns b - GYTxSkeletonNoRefIns <> GYTxSkeletonNoRefIns = GYTxSkeletonNoRefIns + GYTxSkeletonRefIns a <> GYTxSkeletonRefIns b = GYTxSkeletonRefIns (Set.union a b) + GYTxSkeletonRefIns a <> GYTxSkeletonNoRefIns = GYTxSkeletonRefIns a + GYTxSkeletonNoRefIns <> GYTxSkeletonRefIns b = GYTxSkeletonRefIns b + GYTxSkeletonNoRefIns <> GYTxSkeletonNoRefIns = GYTxSkeletonNoRefIns emptyGYTxSkeleton :: GYTxSkeleton v -emptyGYTxSkeleton = GYTxSkeleton - { gytxIns = [] - , gytxOuts = [] - , gytxRefIns = GYTxSkeletonNoRefIns - , gytxMint = Map.empty - , gytxWdrls = [] - , gytxSigs = Set.empty - , gytxCerts = [] +emptyGYTxSkeleton = + GYTxSkeleton + { gytxIns = [] + , gytxOuts = [] + , gytxRefIns = GYTxSkeletonNoRefIns + , gytxMint = Map.empty + , gytxWdrls = [] + , gytxSigs = Set.empty + , gytxCerts = [] , gytxInvalidBefore = Nothing - , gytxInvalidAfter = Nothing - , gytxMetadata = Nothing + , gytxInvalidAfter = Nothing + , gytxMetadata = Nothing } instance Semigroup (GYTxSkeleton v) where - x <> y = GYTxSkeleton - { gytxIns = combineIns (gytxIns x) (gytxIns y) - , gytxOuts = gytxOuts x ++ gytxOuts y - , gytxRefIns = gytxRefIns x <> gytxRefIns y - , gytxMint = combineMint (gytxMint x) (gytxMint y) - , gytxWdrls = combineWdrls (gytxWdrls x) (gytxWdrls y) - , gytxSigs = Set.union (gytxSigs x) (gytxSigs y) - , gytxCerts = gytxCerts x <> gytxCerts y - , gytxInvalidBefore = combineInvalidBefore (gytxInvalidBefore x) (gytxInvalidBefore y) - , gytxInvalidAfter = combineInvalidAfter (gytxInvalidAfter x) (gytxInvalidAfter y) - , gytxMetadata = gytxMetadata x <> gytxMetadata y - } - where - -- we keep only one input per utxo to spend - combineIns u v = nubBy ((==) `on` gyTxInTxOutRef) (u ++ v) - -- we cannot combine redeemers, so we just pick first. - combineMint = Map.unionWith (\(amt, r) (amt', _r) -> (Map.unionWith (+) amt amt', r)) - -- we keep only one withdrawal per stake address - combineWdrls u v = nubBy ((==) `on` gyTxWdrlStakeAddress) (u ++ v) - - combineInvalidBefore :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot - combineInvalidBefore m Nothing = m - combineInvalidBefore Nothing n = n - combineInvalidBefore (Just s) (Just t) = Just (max s t) - - combineInvalidAfter :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot - combineInvalidAfter m Nothing = m - combineInvalidAfter Nothing n = n - combineInvalidAfter (Just s) (Just t) = Just (min s t) + x <> y = + GYTxSkeleton + { gytxIns = combineIns (gytxIns x) (gytxIns y) + , gytxOuts = gytxOuts x ++ gytxOuts y + , gytxRefIns = gytxRefIns x <> gytxRefIns y + , gytxMint = combineMint (gytxMint x) (gytxMint y) + , gytxWdrls = combineWdrls (gytxWdrls x) (gytxWdrls y) + , gytxSigs = Set.union (gytxSigs x) (gytxSigs y) + , gytxCerts = gytxCerts x <> gytxCerts y + , gytxInvalidBefore = combineInvalidBefore (gytxInvalidBefore x) (gytxInvalidBefore y) + , gytxInvalidAfter = combineInvalidAfter (gytxInvalidAfter x) (gytxInvalidAfter y) + , gytxMetadata = gytxMetadata x <> gytxMetadata y + } + where + -- we keep only one input per utxo to spend + combineIns u v = nubBy ((==) `on` gyTxInTxOutRef) (u ++ v) + -- we cannot combine redeemers, so we just pick first. + combineMint = Map.unionWith (\(amt, r) (amt', _r) -> (Map.unionWith (+) amt amt', r)) + -- we keep only one withdrawal per stake address + combineWdrls u v = nubBy ((==) `on` gyTxWdrlStakeAddress) (u ++ v) + + combineInvalidBefore :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot + combineInvalidBefore m Nothing = m + combineInvalidBefore Nothing n = n + combineInvalidBefore (Just s) (Just t) = Just (max s t) + + combineInvalidAfter :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot + combineInvalidAfter m Nothing = m + combineInvalidAfter Nothing n = n + combineInvalidAfter (Just s) (Just t) = Just (min s t) instance Monoid (GYTxSkeleton v) where - mempty = emptyGYTxSkeleton + mempty = emptyGYTxSkeleton ------------------------------------------------------------------------------- -- Transaction building @@ -150,14 +154,14 @@ one fails due to insufficient funds - this type facilitates recovering the three the results. -} data GYTxBuildResult - -- | All given 'GYTxSkeleton's were successfully built. - = GYTxBuildSuccess !(NonEmpty GYTxBody) - -- | Some of the given 'GYTxSkeleton's were successfully built, but the rest failed due to _insufficient funds_. - | GYTxBuildPartialSuccess !GYBalancingError !(NonEmpty GYTxBody) - -- | None of the given 'GYTxSkeleton's could be built due to _insufficient funds_. - | GYTxBuildFailure !GYBalancingError - -- | Input did not contain any 'GYTxSkeleton's. - | GYTxBuildNoInputs + = -- | All given 'GYTxSkeleton's were successfully built. + GYTxBuildSuccess !(NonEmpty GYTxBody) + | -- | Some of the given 'GYTxSkeleton's were successfully built, but the rest failed due to _insufficient funds_. + GYTxBuildPartialSuccess !GYBalancingError !(NonEmpty GYTxBody) + | -- | None of the given 'GYTxSkeleton's could be built due to _insufficient funds_. + GYTxBuildFailure !GYBalancingError + | -- | Input did not contain any 'GYTxSkeleton's. + GYTxBuildNoInputs {- | The core implementation of 'GYTxQueryMonad' for building 'GYTxBody's out of one or more 'GYTxSkeleton's. @@ -171,125 +175,129 @@ Peculiarly, this is parameterized on: The function recovers successfully built tx skeletons, in case the list contains several of them. See: 'GYTxBuildResult'. -} -buildTxCore - :: forall m v. (GYTxQueryMonad m, MonadRandom m) - => Api.SystemStart - -> Api.EraHistory - -> ApiProtocolParameters - -> Set Api.S.PoolId - -> GYCoinSelectionStrategy - -> (GYTxBody -> GYUTxOs -> GYUTxOs) - -> [GYAddress] - -> GYAddress - -> Maybe GYUTxO -- ^ Is `Nothing` if there was no 5 ada collateral returned by browser wallet. - -> [GYTxSkeleton v] - -> m (Either GYBuildTxError GYTxBuildResult) +buildTxCore :: + forall m v. + (GYTxQueryMonad m, MonadRandom m) => + Api.SystemStart -> + Api.EraHistory -> + ApiProtocolParameters -> + Set Api.S.PoolId -> + GYCoinSelectionStrategy -> + (GYTxBody -> GYUTxOs -> GYUTxOs) -> + [GYAddress] -> + GYAddress -> + -- | Is `Nothing` if there was no 5 ada collateral returned by browser wallet. + Maybe GYUTxO -> + [GYTxSkeleton v] -> + m (Either GYBuildTxError GYTxBuildResult) buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral skeletons = do - ownUtxos <- utxosAtAddresses addrs - - let buildEnvWith ownUtxos' refIns collateralUtxo = GYBuildTxEnv - { gyBTxEnvSystemStart = ss - , gyBTxEnvEraHistory = eh - , gyBTxEnvProtocolParams = pp - , gyBTxEnvPools = ps - , gyBTxEnvOwnUtxos = utxosRemoveTxOutRefs refIns $ utxosRemoveRefScripts $ maybe ownUtxos' ((`utxosRemoveTxOutRef` ownUtxos') . utxoRef) reservedCollateral - , gyBTxEnvChangeAddr = change - , gyBTxEnvCollateral = collateralUtxo - } - - helper :: GYUTxOs -> GYTxSkeleton v -> m (Either GYBuildTxError GYTxBody) - helper ownUtxos' GYTxSkeleton {..} = do - let gytxMint' :: Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) - gytxMint' - | null gytxMint = Nothing - | otherwise = - Just - ( valueFromList [ (GYToken (mintingPolicyIdFromWitness mp) tn, n) | (mp, (tokens, _)) <- itoList gytxMint, (tn, n) <- itoList tokens ] - , [(mp, redeemer) | (mp, (_, redeemer)) <- itoList gytxMint] - ) - - let refIns = - gyTxSkeletonRefInsToList gytxRefIns - <> [r | GYTxIn { gyTxInWitness = GYTxInWitnessScript (GYInReference r _) _ _ } <- gytxIns] - <> [r | GYMintReference r _ <- Map.keys gytxMint] - allRefUtxos <- utxosAtTxOutRefs $ - (gyTxInTxOutRef <$> gytxIns) + ownUtxos <- utxosAtAddresses addrs + + let buildEnvWith ownUtxos' refIns collateralUtxo = + GYBuildTxEnv + { gyBTxEnvSystemStart = ss + , gyBTxEnvEraHistory = eh + , gyBTxEnvProtocolParams = pp + , gyBTxEnvPools = ps + , gyBTxEnvOwnUtxos = utxosRemoveTxOutRefs refIns $ utxosRemoveRefScripts $ maybe ownUtxos' ((`utxosRemoveTxOutRef` ownUtxos') . utxoRef) reservedCollateral + , gyBTxEnvChangeAddr = change + , gyBTxEnvCollateral = collateralUtxo + } + + helper :: GYUTxOs -> GYTxSkeleton v -> m (Either GYBuildTxError GYTxBody) + helper ownUtxos' GYTxSkeleton {..} = do + let gytxMint' :: Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) + gytxMint' + | null gytxMint = Nothing + | otherwise = + Just + ( valueFromList [(GYToken (mintingPolicyIdFromWitness mp) tn, n) | (mp, (tokens, _)) <- itoList gytxMint, (tn, n) <- itoList tokens] + , [(mp, redeemer) | (mp, (_, redeemer)) <- itoList gytxMint] + ) + + let refIns = + gyTxSkeletonRefInsToList gytxRefIns + <> [r | GYTxIn {gyTxInWitness = GYTxInWitnessScript (GYInReference r _) _ _} <- gytxIns] + <> [r | GYMintReference r _ <- Map.keys gytxMint] + allRefUtxos <- + utxosAtTxOutRefs $ + (gyTxInTxOutRef <$> gytxIns) <> refIns - refInsUtxos <- forM refIns $ \refIn -> do - case utxosLookup refIn allRefUtxos of - Nothing -> throwError . GYQueryUTxOException $ GYNoUtxoAtRef refIn - Just u -> pure u - -- Convert the 'GYTxIn's to 'GYTxInDetailed's from fetched chain information about them. - gyTxInsDetailed <- forM gytxIns $ \gyTxIn -> do - let ref = gyTxInTxOutRef gyTxIn - case utxosLookup ref allRefUtxos of - Nothing -> throwError . GYQueryUTxOException $ GYNoUtxoAtRef ref - Just GYUTxO {utxoAddress, utxoValue, utxoRefScript, utxoOutDatum} -> - if checkDatumMatch utxoOutDatum $ gyTxInWitness gyTxIn then - pure $ - GYTxInDetailed gyTxIn utxoAddress utxoValue utxoOutDatum utxoRefScript - else throwError $ GYDatumMismatch utxoOutDatum gyTxIn - where - checkDatumMatch _ GYTxInWitnessKey = True - checkDatumMatch _ GYTxInWitnessSimpleScript{} = True - checkDatumMatch ud (GYTxInWitnessScript _ wd _) = case ud of - GYOutDatumNone -> False - GYOutDatumHash h -> h == hashDatum wd - GYOutDatumInline uid -> uid == wd - - - -- This operation is `O(n)` where `n` denotes the number of UTxOs in `ownUtxos'`. - let totalRefScriptSize = foldl' (\acc GYUTxO {..} -> acc + maybe 0 scriptSize utxoRefScript) 0 $ refInsUtxos <> map utxoFromTxInDetailed gyTxInsDetailed - maximumRequiredCollateralValue' = maximumRequiredCollateralValue pp totalRefScriptSize - mCollateralUtxo = - reservedCollateral <|> - find - (\u -> - let v = utxoValue u - -- Following depends on that we allow unsafe, i.e., negative coins count below. In future, we can take magnitude instead. - vWithoutMaxCollPledge = v `valueMinus` maximumRequiredCollateralValue' - worstCaseCollOutput = mkGYTxOutNoDatum change vWithoutMaxCollPledge - -- @vWithoutMaxCollPledge@ should satisfy minimum ada requirement. - in - v `valueGreaterOrEqual` maximumRequiredCollateralValue' - && minimumUTxO pp worstCaseCollOutput <= fromInteger (valueAssetClass vWithoutMaxCollPledge GYLovelace) - ) -- Keeping it simple. - (utxosToList ownUtxos') - - case mCollateralUtxo of - Nothing -> return (Left GYBuildTxNoSuitableCollateral) - Just collateralUtxo -> - -- Build the transaction. - buildUnsignedTxBody - (buildEnvWith ownUtxos' (Set.fromList refIns) collateralUtxo) - cstrat - gyTxInsDetailed - gytxOuts - (utxosFromList refInsUtxos) - gytxMint' - gytxWdrls - gytxCerts - gytxInvalidBefore - gytxInvalidAfter - gytxSigs - gytxMetadata - - go :: GYUTxOs -> GYTxBuildResult -> [GYTxSkeleton v] -> m (Either GYBuildTxError GYTxBuildResult) - go _ acc [] = pure $ Right $ reverseResult acc - go ownUtxos' acc (skeleton : rest) = do - res <- helper ownUtxos' skeleton - case res of - {- Not enough funds for this transaction - We assume it's not worth continuing with the next transactions (which is often the case) -} - Left (GYBuildTxBalancingError be) -> pure $ Right $ reverseResult $ updateBuildRes (Left be) acc - -- Any other exception is fatal. TODO: To think more on whether collateral error can be handled here. - Left err -> pure $ Left err - Right body -> do - -- Update the available utxos set by user supplied function. - let ownUTxos'' = ownUtxoUpdateF body ownUtxos' - -- Continue with an updated accumulator (set of built results). - go ownUTxos'' (updateBuildRes (Right body) acc) rest - go ownUtxos GYTxBuildNoInputs skeletons + refInsUtxos <- forM refIns $ \refIn -> do + case utxosLookup refIn allRefUtxos of + Nothing -> throwError . GYQueryUTxOException $ GYNoUtxoAtRef refIn + Just u -> pure u + -- Convert the 'GYTxIn's to 'GYTxInDetailed's from fetched chain information about them. + gyTxInsDetailed <- forM gytxIns $ \gyTxIn -> do + let ref = gyTxInTxOutRef gyTxIn + case utxosLookup ref allRefUtxos of + Nothing -> throwError . GYQueryUTxOException $ GYNoUtxoAtRef ref + Just GYUTxO {utxoAddress, utxoValue, utxoRefScript, utxoOutDatum} -> + if checkDatumMatch utxoOutDatum $ gyTxInWitness gyTxIn + then + pure $ + GYTxInDetailed gyTxIn utxoAddress utxoValue utxoOutDatum utxoRefScript + else throwError $ GYDatumMismatch utxoOutDatum gyTxIn + where + checkDatumMatch _ GYTxInWitnessKey = True + checkDatumMatch _ GYTxInWitnessSimpleScript {} = True + checkDatumMatch ud (GYTxInWitnessScript _ wd _) = case ud of + GYOutDatumNone -> False + GYOutDatumHash h -> h == hashDatum wd + GYOutDatumInline uid -> uid == wd + + -- This operation is `O(n)` where `n` denotes the number of UTxOs in `ownUtxos'`. + let totalRefScriptSize = foldl' (\acc GYUTxO {..} -> acc + maybe 0 scriptSize utxoRefScript) 0 $ refInsUtxos <> map utxoFromTxInDetailed gyTxInsDetailed + maximumRequiredCollateralValue' = maximumRequiredCollateralValue pp totalRefScriptSize + mCollateralUtxo = + reservedCollateral + <|> find + ( \u -> + let v = utxoValue u + -- Following depends on that we allow unsafe, i.e., negative coins count below. In future, we can take magnitude instead. + vWithoutMaxCollPledge = v `valueMinus` maximumRequiredCollateralValue' + worstCaseCollOutput = mkGYTxOutNoDatum change vWithoutMaxCollPledge + in -- @vWithoutMaxCollPledge@ should satisfy minimum ada requirement. + + v `valueGreaterOrEqual` maximumRequiredCollateralValue' + && minimumUTxO pp worstCaseCollOutput <= fromInteger (valueAssetClass vWithoutMaxCollPledge GYLovelace) + ) -- Keeping it simple. + (utxosToList ownUtxos') + + case mCollateralUtxo of + Nothing -> return (Left GYBuildTxNoSuitableCollateral) + Just collateralUtxo -> + -- Build the transaction. + buildUnsignedTxBody + (buildEnvWith ownUtxos' (Set.fromList refIns) collateralUtxo) + cstrat + gyTxInsDetailed + gytxOuts + (utxosFromList refInsUtxos) + gytxMint' + gytxWdrls + gytxCerts + gytxInvalidBefore + gytxInvalidAfter + gytxSigs + gytxMetadata + + go :: GYUTxOs -> GYTxBuildResult -> [GYTxSkeleton v] -> m (Either GYBuildTxError GYTxBuildResult) + go _ acc [] = pure $ Right $ reverseResult acc + go ownUtxos' acc (skeleton : rest) = do + res <- helper ownUtxos' skeleton + case res of + {- Not enough funds for this transaction + We assume it's not worth continuing with the next transactions (which is often the case) -} + Left (GYBuildTxBalancingError be) -> pure $ Right $ reverseResult $ updateBuildRes (Left be) acc + -- Any other exception is fatal. TODO: To think more on whether collateral error can be handled here. + Left err -> pure $ Left err + Right body -> do + -- Update the available utxos set by user supplied function. + let ownUTxos'' = ownUtxoUpdateF body ownUtxos' + -- Continue with an updated accumulator (set of built results). + go ownUTxos'' (updateBuildRes (Right body) acc) rest + go ownUtxos GYTxBuildNoInputs skeletons where {- This function updates 'GYTxBuildResult' based on a build outcome @@ -303,14 +311,14 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk It's impossible for the second argument to ever be 'GYTxBuildFailure' or 'GYTxBuildPartialSuccess', as the outer function 'go' (see above) always exits as soon as the accumulator updates to one of these. -} - updateBuildRes (Left v) GYTxBuildNoInputs = GYTxBuildFailure v - updateBuildRes (Left v) (GYTxBuildSuccess ne) = GYTxBuildPartialSuccess v ne - updateBuildRes (Right x) GYTxBuildNoInputs = GYTxBuildSuccess (x :| []) + updateBuildRes (Left v) GYTxBuildNoInputs = GYTxBuildFailure v + updateBuildRes (Left v) (GYTxBuildSuccess ne) = GYTxBuildPartialSuccess v ne + updateBuildRes (Right x) GYTxBuildNoInputs = GYTxBuildSuccess (x :| []) updateBuildRes (Right x) (GYTxBuildSuccess ne) = GYTxBuildSuccess (NE.cons x ne) - updateBuildRes _ _ = error "buildTxCore.flippedFoldM.updateBuildRes: absurd" + updateBuildRes _ _ = error "buildTxCore.flippedFoldM.updateBuildRes: absurd" -- TODO: Move to @Data.Sequence.NonEmpty@? - -- | To reverse the final non-empty list built. + -- \| To reverse the final non-empty list built. reverseResult :: GYTxBuildResult -> GYTxBuildResult reverseResult (GYTxBuildSuccess ne) = GYTxBuildSuccess $ NE.reverse ne reverseResult (GYTxBuildPartialSuccess v ne) = GYTxBuildPartialSuccess v $ NE.reverse ne @@ -322,12 +330,14 @@ collateralLovelace = 5_000_000 collateralValue :: GYValue collateralValue = valueFromLovelace collateralLovelace -{-# INLINABLE maximumRequiredCollateralLovelace #-} +{-# INLINEABLE maximumRequiredCollateralLovelace #-} + -- | What is the maximum possible collateral requirement as per current protocol parameters? maximumRequiredCollateralLovelace :: ApiProtocolParameters -> Int -> Integer maximumRequiredCollateralLovelace pp refScriptSize = ceiling $ fromIntegral (maximumFee pp refScriptSize) * ((pp ^. Ledger.ppCollateralPercentageL) % 100) -{-# INLINABLE maximumFee #-} +{-# INLINEABLE maximumFee #-} + -- | Compute the maximum fee possible for any transaction. maximumFee :: ApiProtocolParameters -> Int -> Integer maximumFee pp refScriptSize = @@ -336,12 +346,13 @@ maximumFee pp refScriptSize = executionFee :: Rational executionFee = case (pp ^. Ledger.ppPricesL, pp ^. Ledger.ppMaxTxExUnitsL) of - (Ledger.Prices{..}, Ledger.ExUnits {..}) -> + (Ledger.Prices {..}, Ledger.ExUnits {..}) -> Ledger.unboundRational prSteps * fromIntegral exUnitsSteps + Ledger.unboundRational prMem * fromIntegral exUnitsMem refScriptFee = Ledger.tierRefScriptFee 1.2 25_600 (unboundRational $ pp ^. Ledger.ppMinFeeRefScriptCostPerByteL) refScriptSize in txFee + ceiling executionFee + Ledger.unCoin refScriptFee -{-# INLINABLE maximumRequiredCollateralValue #-} +{-# INLINEABLE maximumRequiredCollateralValue #-} + -- | See `maximumRequiredCollateralLovelace`. maximumRequiredCollateralValue :: ApiProtocolParameters -> Int -> GYValue maximumRequiredCollateralValue pp refScriptSize = valueFromLovelace $ maximumRequiredCollateralLovelace pp refScriptSize diff --git a/src/GeniusYield/TxBuilder/Errors.hs b/src/GeniusYield/TxBuilder/Errors.hs index d1a2a66b..2055774c 100644 --- a/src/GeniusYield/TxBuilder/Errors.hs +++ b/src/GeniusYield/TxBuilder/Errors.hs @@ -1,39 +1,38 @@ -{-| +{- | Module : GeniusYield.TxBuilder.Errors Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.TxBuilder.Errors - ( PlutusToCardanoError (..) - , GYConversionError (..) - , GYQueryUTxOError (..) - , GYQueryDatumError (..) - , GYTxMonadException (..) - , GYBuildTxError (..) - , GYBalancingError (..) - , throwAppError - ) where +module GeniusYield.TxBuilder.Errors ( + PlutusToCardanoError (..), + GYConversionError (..), + GYQueryUTxOError (..), + GYQueryDatumError (..), + GYTxMonadException (..), + GYBuildTxError (..), + GYBalancingError (..), + throwAppError, +) where -import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Except (MonadError, throwError) -import Cardano.Slotting.Time (SystemStart) -import qualified PlutusLedgerApi.V1.Value as Plutus (Value) +import Cardano.Slotting.Time (SystemStart) +import PlutusLedgerApi.V1.Value qualified as Plutus (Value) -import GeniusYield.HTTP.Errors -import GeniusYield.Imports -import GeniusYield.Transaction.Common -import GeniusYield.Types.Address (GYAddress) -import GeniusYield.Types.Datum (GYDatum, GYDatumHash) -import GeniusYield.Types.Ledger (PlutusToCardanoError (..)) -import GeniusYield.Types.Slot (GYSlot) -import GeniusYield.Types.Time (GYTime) -import GeniusYield.Types.TxOutRef (GYTxOutRef) -import GeniusYield.Types.UTxO (GYUTxO, GYOutDatum) -import GeniusYield.Types.Value (GYFromPlutusValueError) -import GeniusYield.Types.TxIn (GYTxIn) +import GeniusYield.HTTP.Errors +import GeniusYield.Imports +import GeniusYield.Transaction.Common +import GeniusYield.Types.Address (GYAddress) +import GeniusYield.Types.Datum (GYDatum, GYDatumHash) +import GeniusYield.Types.Ledger (PlutusToCardanoError (..)) +import GeniusYield.Types.Slot (GYSlot) +import GeniusYield.Types.Time (GYTime) +import GeniusYield.Types.TxIn (GYTxIn) +import GeniusYield.Types.TxOutRef (GYTxOutRef) +import GeniusYield.Types.UTxO (GYOutDatum, GYUTxO) +import GeniusYield.Types.Value (GYFromPlutusValueError) ------------------------------------------------------------------------------- -- Exception @@ -41,43 +40,43 @@ import GeniusYield.Types.TxIn (GYTxIn) -- | 'GYConversionError's may be raised during type conversions. data GYConversionError - -- | An address was expected to contain a pub key hash, but it did not. - = GYNotPubKeyAddress !GYAddress - -- | An address was expected to contain a script hash, but it did not. - | GYNotScriptAddress !GYAddress - -- | Raised during Plutus Value to 'GeniusYield.Types.Value.GYValue' conversion. - | GYInvalidPlutusValue !GYFromPlutusValueError !Plutus.Value - -- | Raised during Plutus asset to GY asset conversion. - | GYInvalidPlutusAsset !GYFromPlutusValueError - -- | Raised when trying to parse 'Text' into 'GYAddress'. - | GYInvalidAddressText !Text - -- | Raised when trying to convert EraHistory to GYSlotConfig. - | GYEraSummariesToSlotConfigError !Text - -- | Errors raised during plutus-ledger -> cardano api type conversion. - | GYLedgerToCardanoError !PlutusToCardanoError - -- | Errors raised by "GeniusYield.Types.Value.parseAssetClassCore" and similar. - | GYInvalidAssetClass !Text - -- | Errors caused by "GeniusYield.Types.Slot.slotFromInteger" resulting in 'Nothing'. - | GYInvalidSlot !Integer - deriving stock Show + = -- | An address was expected to contain a pub key hash, but it did not. + GYNotPubKeyAddress !GYAddress + | -- | An address was expected to contain a script hash, but it did not. + GYNotScriptAddress !GYAddress + | -- | Raised during Plutus Value to 'GeniusYield.Types.Value.GYValue' conversion. + GYInvalidPlutusValue !GYFromPlutusValueError !Plutus.Value + | -- | Raised during Plutus asset to GY asset conversion. + GYInvalidPlutusAsset !GYFromPlutusValueError + | -- | Raised when trying to parse 'Text' into 'GYAddress'. + GYInvalidAddressText !Text + | -- | Raised when trying to convert EraHistory to GYSlotConfig. + GYEraSummariesToSlotConfigError !Text + | -- | Errors raised during plutus-ledger -> cardano api type conversion. + GYLedgerToCardanoError !PlutusToCardanoError + | -- | Errors raised by "GeniusYield.Types.Value.parseAssetClassCore" and similar. + GYInvalidAssetClass !Text + | -- | Errors caused by "GeniusYield.Types.Slot.slotFromInteger" resulting in 'Nothing'. + GYInvalidSlot !Integer + deriving stock (Show) -- | 'GYQueryUTxOError's may be raised during utxo related queries. data GYQueryUTxOError - -- | An address was queried for one or more UTxOs but none were found. - = GYNoUtxosAtAddress ![GYAddress] - -- | No UTxO exists at given ref. - | GYNoUtxoAtRef !GYTxOutRef - deriving stock Show + = -- | An address was queried for one or more UTxOs but none were found. + GYNoUtxosAtAddress ![GYAddress] + | -- | No UTxO exists at given ref. + GYNoUtxoAtRef !GYTxOutRef + deriving stock (Show) -- | 'GYQueryDatumError' may be raised during fetching and parsing datums. data GYQueryDatumError - -- | No datum found for given hash. - = GYNoDatumForHash !GYDatumHash - -- | Datum parsing failed. - | GYInvalidDatum !GYDatum - -- | No datum hash at utxo. - | GYNoDatumHash !GYUTxO - deriving stock Show + = -- | No datum found for given hash. + GYNoDatumForHash !GYDatumHash + | -- | Datum parsing failed. + GYInvalidDatum !GYDatum + | -- | No datum hash at utxo. + GYNoDatumHash !GYUTxO + deriving stock (Show) {- | Exceptions raised within the 'GeniusYield.TxBuilder.Class.GYTxMonad' computation. @@ -88,25 +87,25 @@ This includes exceptions raised within the contract itself. It does not include: - Other wildcard exceptions raised within IO. -} data GYTxMonadException :: Type where - -- | Errors encountered during type conversions. - GYConversionException :: GYConversionError -> GYTxMonadException - -- | Errors encountered during utxo related queries. - GYQueryUTxOException :: GYQueryUTxOError -> GYTxMonadException - -- | Errors encountered during transaction building related functions. - GYBuildTxException :: GYBuildTxError -> GYTxMonadException - -- | Raised when no suitable collateral of at least 'tmeMinLovelace' amount is found at 'tmeAddress'. - GYNoSuitableCollateralException :: { tmeMinLovelace :: Natural, tmeAddress :: GYAddress } -> GYTxMonadException - -- | Raised if 'tmeSlot' value overflows when advancing it by 'tmeAdvanceAmount'. - GYSlotOverflowException :: { tmeSlot :: GYSlot, tmeAdvanceAmount :: Natural } -> GYTxMonadException - -- | Raised during time -> slot conversion, if given timestamp is before known system start. - GYTimeUnderflowException :: SystemStart -> GYTime -> GYTxMonadException - -- | Raised during fetching/parsing datums. - GYQueryDatumException :: GYQueryDatumError -> GYTxMonadException - -- | When actual datum in the UTxO is different than what is mentioned for in witness. - GYDatumMismatch :: GYOutDatum -> GYTxIn v -> GYTxMonadException - {- | Wildcard user application specific errors. This is the "plug-in" point where an application - using the GY framework, can raise its own protocol specific errors within 'GeniusYield.TxBuilder.Class.GYTxMonad'. -} - GYApplicationException :: (Exception e, IsGYApiError e) => e -> GYTxMonadException + -- | Errors encountered during type conversions. + GYConversionException :: GYConversionError -> GYTxMonadException + -- | Errors encountered during utxo related queries. + GYQueryUTxOException :: GYQueryUTxOError -> GYTxMonadException + -- | Errors encountered during transaction building related functions. + GYBuildTxException :: GYBuildTxError -> GYTxMonadException + -- | Raised when no suitable collateral of at least 'tmeMinLovelace' amount is found at 'tmeAddress'. + GYNoSuitableCollateralException :: {tmeMinLovelace :: Natural, tmeAddress :: GYAddress} -> GYTxMonadException + -- | Raised if 'tmeSlot' value overflows when advancing it by 'tmeAdvanceAmount'. + GYSlotOverflowException :: {tmeSlot :: GYSlot, tmeAdvanceAmount :: Natural} -> GYTxMonadException + -- | Raised during time -> slot conversion, if given timestamp is before known system start. + GYTimeUnderflowException :: SystemStart -> GYTime -> GYTxMonadException + -- | Raised during fetching/parsing datums. + GYQueryDatumException :: GYQueryDatumError -> GYTxMonadException + -- | When actual datum in the UTxO is different than what is mentioned for in witness. + GYDatumMismatch :: GYOutDatum -> GYTxIn v -> GYTxMonadException + -- | Wildcard user application specific errors. This is the "plug-in" point where an application + -- using the GY framework, can raise its own protocol specific errors within 'GeniusYield.TxBuilder.Class.GYTxMonad'. + GYApplicationException :: (Exception e, IsGYApiError e) => e -> GYTxMonadException deriving instance Show GYTxMonadException diff --git a/src/GeniusYield/TxBuilder/IO.hs b/src/GeniusYield/TxBuilder/IO.hs index 279ba774..1f1e27da 100644 --- a/src/GeniusYield/TxBuilder/IO.hs +++ b/src/GeniusYield/TxBuilder/IO.hs @@ -1,37 +1,38 @@ -{-| +{- | Module : GeniusYield.TxBuilder.IO Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.TxBuilder.IO ( - GYTxGameMonadIO, - GYTxMonadIO, - GYTxQueryMonadIO, - GYTxBuilderMonadIO, - runGYTxBuilderMonadIO, - runGYTxQueryMonadIO, - runGYTxMonadIO, - runGYTxGameMonadIO, - queryAsBuilderMonad, - liftQueryMonad, - liftBuilderMonad + GYTxGameMonadIO, + GYTxMonadIO, + GYTxQueryMonadIO, + GYTxBuilderMonadIO, + runGYTxBuilderMonadIO, + runGYTxQueryMonadIO, + runGYTxMonadIO, + runGYTxGameMonadIO, + queryAsBuilderMonad, + liftQueryMonad, + liftBuilderMonad, ) where - -import Control.Monad.Reader (MonadReader, - ReaderT (ReaderT), asks) -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T - -import GeniusYield.TxBuilder.Class -import GeniusYield.TxBuilder.Errors -import GeniusYield.TxBuilder.IO.Builder -import GeniusYield.TxBuilder.IO.Query -import GeniusYield.TxBuilder.User -import GeniusYield.Types +import Control.Monad.Reader ( + MonadReader, + ReaderT (ReaderT), + asks, + ) +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T + +import GeniusYield.TxBuilder.Class +import GeniusYield.TxBuilder.Errors +import GeniusYield.TxBuilder.IO.Builder +import GeniusYield.TxBuilder.IO.Query +import GeniusYield.TxBuilder.User +import GeniusYield.Types ------------------------------------------------------------------------------- -- GY implementation @@ -39,26 +40,28 @@ import GeniusYield.Types -- | 'GYTxMonad' interpretation run under IO. type role GYTxMonadIO representational + newtype GYTxMonadIO a = GYTxMonadIO (GYTxIOEnv -> GYTxBuilderMonadIO a) - deriving ( Functor - , Applicative - , Monad - , MonadReader GYTxIOEnv - , MonadRandom - , MonadError GYTxMonadException - , GYTxQueryMonad - , GYTxSpecialQueryMonad - , GYTxUserQueryMonad - , GYTxBuilderMonad - ) - via ReaderT GYTxIOEnv GYTxBuilderMonadIO + deriving + ( Functor + , Applicative + , Monad + , MonadReader GYTxIOEnv + , MonadRandom + , MonadError GYTxMonadException + , GYTxQueryMonad + , GYTxSpecialQueryMonad + , GYTxUserQueryMonad + , GYTxBuilderMonad + ) + via ReaderT GYTxIOEnv GYTxBuilderMonadIO data GYTxIOEnv = GYTxIOEnv - { envNid :: !GYNetworkId - , envProviders :: !GYProviders - , envPaymentSKey :: !GYPaymentSigningKey - , envStakeSKey :: !(Maybe GYStakeSigningKey) - } + { envNid :: !GYNetworkId + , envProviders :: !GYProviders + , envPaymentSKey :: !GYPaymentSigningKey + , envStakeSKey :: !(Maybe GYStakeSigningKey) + } -- INTERNAL USAGE ONLY -- Do not expose a 'MonadIO' instance. It allows the user to do arbitrary IO within the tx monad. @@ -74,30 +77,39 @@ liftQueryMonad :: GYTxQueryMonadIO a -> GYTxMonadIO a liftQueryMonad = GYTxMonadIO . pure . queryAsBuilderMonad instance GYTxMonad GYTxMonadIO where - signTxBody = signTxBodyImpl $ asks envPaymentSKey - - signTxBodyWithStake = signTxBodyWithStakeImpl $ asks ((,) . envPaymentSKey) <*> asks envStakeSKey - - submitTx tx = do - txSubmitter <- asks (gySubmitTx . envProviders) - ioToTxMonad $ txSubmitter tx - - awaitTxConfirmed' params txId = do - txAwaiter <- asks (gyAwaitTxConfirmed . envProviders) - ioToTxMonad $ txAwaiter params txId - -runGYTxMonadIO - :: GYNetworkId -- ^ Network ID. - -> GYProviders -- ^ Provider. - -> GYPaymentSigningKey -- ^ Payment signing key of the wallet - -> Maybe GYStakeSigningKey -- ^ Stake signing key of the wallet (optional) - -> [GYAddress] -- ^ Addresses belonging to wallet. - -> GYAddress -- ^ Change address. - -> Maybe (GYTxOutRef, Bool) -- ^ If `Nothing` is provided, framework would pick up a suitable UTxO as collateral and in such case is also free to spend it. If something is given with boolean being `False` then framework will use the given `GYTxOutRef` as collateral and would reserve it as well. But if boolean is `True`, framework would only use it as collateral and reserve it, if value in the given UTxO is exactly 5 ada. - -> GYTxMonadIO a - -> IO a + signTxBody = signTxBodyImpl $ asks envPaymentSKey + + signTxBodyWithStake = signTxBodyWithStakeImpl $ asks ((,) . envPaymentSKey) <*> asks envStakeSKey + + submitTx tx = do + txSubmitter <- asks (gySubmitTx . envProviders) + ioToTxMonad $ txSubmitter tx + + awaitTxConfirmed' params txId = do + txAwaiter <- asks (gyAwaitTxConfirmed . envProviders) + ioToTxMonad $ txAwaiter params txId + +runGYTxMonadIO :: + -- | Network ID. + GYNetworkId -> + -- | Provider. + GYProviders -> + -- | Payment signing key of the wallet + GYPaymentSigningKey -> + -- | Stake signing key of the wallet (optional) + Maybe GYStakeSigningKey -> + -- | Addresses belonging to wallet. + [GYAddress] -> + -- | Change address. + GYAddress -> + -- | If `Nothing` is provided, framework would pick up a suitable UTxO as collateral and in such case is also free to spend it. If something is given with boolean being `False` then framework will use the given `GYTxOutRef` as collateral and would reserve it as well. But if boolean is `True`, framework would only use it as collateral and reserve it, if value in the given UTxO is exactly 5 ada. + Maybe (GYTxOutRef, Bool) -> + GYTxMonadIO a -> + IO a runGYTxMonadIO envNid envProviders envPaymentSKey envStakeSKey envAddrs envChangeAddr collateral (GYTxMonadIO action) = do - runGYTxBuilderMonadIO envNid envProviders envAddrs envChangeAddr collateral $ action GYTxIOEnv + runGYTxBuilderMonadIO envNid envProviders envAddrs envChangeAddr collateral $ + action + GYTxIOEnv { envNid , envProviders , envPaymentSKey @@ -106,74 +118,82 @@ runGYTxMonadIO envNid envProviders envPaymentSKey envStakeSKey envAddrs envChang -- | 'GYTxMonad' interpretation run under IO. type role GYTxGameMonadIO representational -newtype GYTxGameMonadIO a = GYTxGameMonadIO (GYTxGameIOEnv -> GYTxQueryMonadIO a) -{- Note: The implementation of 'GYTxGameMonadIO' is pretty hacky. It should really be read as 'GYTxGameIOEnv -> GYTxQueryMonadIO a', -because that's what is really happening. We use 'GYTxQueryMonadIO' just to auto derive the relevant instances. But in reality, -we'll be using internal functions to lift IO functions into 'GYTxQueryMonadIO' and _pretend_ to be 'GYTxQueryMonadIO'. -The usage is controlled, and we do _mean_ to do IO within 'GYTxGameMonadIO'. So it is advised to simply read the impl as suggested above. --} - deriving ( Functor - , Applicative - , Monad - , MonadReader GYTxGameIOEnv - , MonadRandom - , MonadError GYTxMonadException - , GYTxQueryMonad - , GYTxSpecialQueryMonad - ) - via ReaderT GYTxGameIOEnv GYTxQueryMonadIO +newtype GYTxGameMonadIO a = GYTxGameMonadIO (GYTxGameIOEnv -> GYTxQueryMonadIO a) + {- Note: The implementation of 'GYTxGameMonadIO' is pretty hacky. It should really be read as 'GYTxGameIOEnv -> GYTxQueryMonadIO a', + because that's what is really happening. We use 'GYTxQueryMonadIO' just to auto derive the relevant instances. But in reality, + we'll be using internal functions to lift IO functions into 'GYTxQueryMonadIO' and _pretend_ to be 'GYTxQueryMonadIO'. + + The usage is controlled, and we do _mean_ to do IO within 'GYTxGameMonadIO'. So it is advised to simply read the impl as suggested above. + -} + deriving + ( Functor + , Applicative + , Monad + , MonadReader GYTxGameIOEnv + , MonadRandom + , MonadError GYTxMonadException + , GYTxQueryMonad + , GYTxSpecialQueryMonad + ) + via ReaderT GYTxGameIOEnv GYTxQueryMonadIO data GYTxGameIOEnv = GYTxGameIOEnv - { envGameNid :: !GYNetworkId - , envGameProviders :: !GYProviders - } + { envGameNid :: !GYNetworkId + , envGameProviders :: !GYProviders + } --- | INTERNAL USAGE ONLY --- --- Do not expose a 'MonadIO' instance. It allows the user to do arbitrary IO within the tx monad. +{- | INTERNAL USAGE ONLY + +Do not expose a 'MonadIO' instance. It allows the user to do arbitrary IO within the tx monad. +-} ioToTxGameMonad :: IO a -> GYTxGameMonadIO a ioToTxGameMonad ioAct = GYTxGameMonadIO . const $ ioToQueryMonad ioAct instance GYTxGameMonad GYTxGameMonadIO where - type TxMonadOf GYTxGameMonadIO = GYTxMonadIO - - createUser = do - nid <- networkId - paymentSKey <- ioToTxGameMonad generatePaymentSigningKey - stakeSKey <- Just <$> ioToTxGameMonad generateStakeSigningKey - let paymentVKey = paymentVerificationKey paymentSKey - stakeVKey = stakeVerificationKey <$> stakeSKey - pkh = paymentKeyHash paymentVKey - skh = stakeKeyHash <$> stakeVKey - newAddr = addressFromCredential - nid - (GYPaymentCredentialByKey pkh) - (GYStakeCredentialByKey <$> skh) - gyLogDebug' "createUser" . T.unpack $ "Created user with address: " <> addressToText newAddr - pure $ User' {userPaymentSKey' = paymentSKey, userAddr = newAddr, userStakeSKey' = stakeSKey} - - asUser u@User{..} act = do - nid <- asks envGameNid - providers <- asks envGameProviders - ioToTxGameMonad $ - runGYTxMonadIO + type TxMonadOf GYTxGameMonadIO = GYTxMonadIO + + createUser = do + nid <- networkId + paymentSKey <- ioToTxGameMonad generatePaymentSigningKey + stakeSKey <- Just <$> ioToTxGameMonad generateStakeSigningKey + let paymentVKey = paymentVerificationKey paymentSKey + stakeVKey = stakeVerificationKey <$> stakeSKey + pkh = paymentKeyHash paymentVKey + skh = stakeKeyHash <$> stakeVKey + newAddr = + addressFromCredential nid - providers - userPaymentSKey - userStakeSKey - (NE.toList userAddresses) - userChangeAddress - (userCollateralDumb u) - act - -runGYTxGameMonadIO - :: GYNetworkId -- ^ Network ID. - -> GYProviders -- ^ Provider. - -> GYTxGameMonadIO a - -> IO a + (GYPaymentCredentialByKey pkh) + (GYStakeCredentialByKey <$> skh) + gyLogDebug' "createUser" . T.unpack $ "Created user with address: " <> addressToText newAddr + pure $ User' {userPaymentSKey' = paymentSKey, userAddr = newAddr, userStakeSKey' = stakeSKey} + + asUser u@User {..} act = do + nid <- asks envGameNid + providers <- asks envGameProviders + ioToTxGameMonad $ + runGYTxMonadIO + nid + providers + userPaymentSKey + userStakeSKey + (NE.toList userAddresses) + userChangeAddress + (userCollateralDumb u) + act + +runGYTxGameMonadIO :: + -- | Network ID. + GYNetworkId -> + -- | Provider. + GYProviders -> + GYTxGameMonadIO a -> + IO a runGYTxGameMonadIO envGameNid envGameProviders (GYTxGameMonadIO action) = do - runGYTxQueryMonadIO envGameNid envGameProviders $ action GYTxGameIOEnv + runGYTxQueryMonadIO envGameNid envGameProviders $ + action + GYTxGameIOEnv { envGameNid , envGameProviders } diff --git a/src/GeniusYield/TxBuilder/IO/Builder.hs b/src/GeniusYield/TxBuilder/IO/Builder.hs index 5717b33d..cfa76671 100644 --- a/src/GeniusYield/TxBuilder/IO/Builder.hs +++ b/src/GeniusYield/TxBuilder/IO/Builder.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.TxBuilder.IO.Builder Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 @@ -8,24 +8,27 @@ Stability : develop **INTERNAL MODULE** -} module GeniusYield.TxBuilder.IO.Builder ( - GYTxBuilderMonadIO, - runGYTxBuilderMonadIO, - ioToTxBuilderMonad, - queryAsBuilderMonad, + GYTxBuilderMonadIO, + runGYTxBuilderMonadIO, + ioToTxBuilderMonad, + queryAsBuilderMonad, ) where - -import Control.Monad.Reader (MonadIO (liftIO), MonadReader, - ReaderT (ReaderT), asks) -import Control.Monad.Trans.Maybe (MaybeT (runMaybeT)) -import qualified Data.Set as Set - -import GeniusYield.Imports -import GeniusYield.TxBuilder.Class -import GeniusYield.TxBuilder.Common -import GeniusYield.TxBuilder.Errors -import GeniusYield.TxBuilder.IO.Query -import GeniusYield.Types +import Control.Monad.Reader ( + MonadIO (liftIO), + MonadReader, + ReaderT (ReaderT), + asks, + ) +import Control.Monad.Trans.Maybe (MaybeT (runMaybeT)) +import Data.Set qualified as Set + +import GeniusYield.Imports +import GeniusYield.TxBuilder.Class +import GeniusYield.TxBuilder.Common +import GeniusYield.TxBuilder.Errors +import GeniusYield.TxBuilder.IO.Query +import GeniusYield.Types ------------------------------------------------------------------------------- -- GY implementation @@ -33,29 +36,32 @@ import GeniusYield.Types -- | 'GYTxUserQueryMonad' interpretation run under IO. type role GYTxBuilderMonadIO representational + newtype GYTxBuilderMonadIO a = GYTxBuilderMonadIO (GYTxBuilderIOEnv -> GYTxQueryMonadIO a) - deriving ( Functor - , Applicative - , Monad - , MonadReader GYTxBuilderIOEnv - , MonadRandom - , MonadError GYTxMonadException - , GYTxQueryMonad - , GYTxSpecialQueryMonad - ) - via ReaderT GYTxBuilderIOEnv GYTxQueryMonadIO - deriving anyclass GYTxBuilderMonad + deriving + ( Functor + , Applicative + , Monad + , MonadReader GYTxBuilderIOEnv + , MonadRandom + , MonadError GYTxMonadException + , GYTxQueryMonad + , GYTxSpecialQueryMonad + ) + via ReaderT GYTxBuilderIOEnv GYTxQueryMonadIO + deriving anyclass (GYTxBuilderMonad) data GYTxBuilderIOEnv = GYTxBuilderIOEnv - { envAddrs :: ![GYAddress] - , envChangeAddr :: !GYAddress - , envCollateral :: !(Maybe GYUTxO) - , envUsedSomeUTxOs :: !(Set GYTxOutRef) - } - --- | INTERNAL USAGE ONLY --- --- Do not expose a 'MonadIO' instance. It allows the user to do arbitrary IO within the tx monad. + { envAddrs :: ![GYAddress] + , envChangeAddr :: !GYAddress + , envCollateral :: !(Maybe GYUTxO) + , envUsedSomeUTxOs :: !(Set GYTxOutRef) + } + +{- | INTERNAL USAGE ONLY + +Do not expose a 'MonadIO' instance. It allows the user to do arbitrary IO within the tx monad. +-} ioToTxBuilderMonad :: IO a -> GYTxBuilderMonadIO a ioToTxBuilderMonad ioAct = GYTxBuilderMonadIO . const $ ioToQueryMonad ioAct @@ -64,62 +70,70 @@ queryAsBuilderMonad :: GYTxQueryMonadIO a -> GYTxBuilderMonadIO a queryAsBuilderMonad = GYTxBuilderMonadIO . pure instance GYTxUserQueryMonad GYTxBuilderMonadIO where + ownAddresses = asks envAddrs - ownAddresses = asks envAddrs - - ownChangeAddress = asks envChangeAddr - - ownCollateral = asks envCollateral - - availableUTxOs = do - addrs <- ownAddresses - mCollateral <- getCollateral - usedSomeUTxOs <- getUsedSomeUTxOs - utxos <- utxosAtAddresses addrs - return $ utxosRemoveTxOutRefs (maybe usedSomeUTxOs ((`Set.insert` usedSomeUTxOs) . utxoRef) mCollateral) utxos - where - getCollateral = asks envCollateral - getUsedSomeUTxOs = asks envUsedSomeUTxOs - - someUTxO lang = do - addrs <- ownAddresses - utxosToConsider <- availableUTxOs - case lang of - PlutusV3 -> ifNotV1 utxosToConsider addrs - PlutusV2 -> ifNotV1 utxosToConsider addrs - PlutusV1 -> - case find utxoTranslatableToV1 $ utxosToList utxosToConsider of - Just u -> return $ utxoRef u - Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Better error message here? - where - ifNotV1 utxosToConsider addrs = - case someTxOutRef utxosToConsider of - Just (oref, _) -> return oref - Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs - -runGYTxBuilderMonadIO - :: GYNetworkId -- ^ Network ID. - -> GYProviders -- ^ Provider. - -> [GYAddress] -- ^ Addresses belonging to wallet. - -> GYAddress -- ^ Change address. - -> Maybe (GYTxOutRef, Bool) -- ^ If `Nothing` is provided, framework would pick up a suitable UTxO as collateral and in such case is also free to spend it. If something is given with boolean being `False` then framework will use the given `GYTxOutRef` as collateral and would reserve it as well. But if boolean is `True`, framework would only use it as collateral and reserve it, if value in the given UTxO is exactly 5 ada. - -> GYTxBuilderMonadIO a - -> IO a + ownChangeAddress = asks envChangeAddr + + ownCollateral = asks envCollateral + + availableUTxOs = do + addrs <- ownAddresses + mCollateral <- getCollateral + usedSomeUTxOs <- getUsedSomeUTxOs + utxos <- utxosAtAddresses addrs + return $ utxosRemoveTxOutRefs (maybe usedSomeUTxOs ((`Set.insert` usedSomeUTxOs) . utxoRef) mCollateral) utxos + where + getCollateral = asks envCollateral + getUsedSomeUTxOs = asks envUsedSomeUTxOs + + someUTxO lang = do + addrs <- ownAddresses + utxosToConsider <- availableUTxOs + case lang of + PlutusV3 -> ifNotV1 utxosToConsider addrs + PlutusV2 -> ifNotV1 utxosToConsider addrs + PlutusV1 -> + case find utxoTranslatableToV1 $ utxosToList utxosToConsider of + Just u -> return $ utxoRef u + Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Better error message here? + where + ifNotV1 utxosToConsider addrs = + case someTxOutRef utxosToConsider of + Just (oref, _) -> return oref + Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs + +runGYTxBuilderMonadIO :: + -- | Network ID. + GYNetworkId -> + -- | Provider. + GYProviders -> + -- | Addresses belonging to wallet. + [GYAddress] -> + -- | Change address. + GYAddress -> + -- | If `Nothing` is provided, framework would pick up a suitable UTxO as collateral and in such case is also free to spend it. If something is given with boolean being `False` then framework will use the given `GYTxOutRef` as collateral and would reserve it as well. But if boolean is `True`, framework would only use it as collateral and reserve it, if value in the given UTxO is exactly 5 ada. + Maybe (GYTxOutRef, Bool) -> + GYTxBuilderMonadIO a -> + IO a runGYTxBuilderMonadIO envNid envProviders envAddrs envChangeAddr collateral (GYTxBuilderMonadIO action) = do - collateral' <- obtainCollateral + collateral' <- obtainCollateral - runGYTxQueryMonadIO envNid envProviders $ action GYTxBuilderIOEnv + runGYTxQueryMonadIO envNid envProviders $ + action + GYTxBuilderIOEnv { envAddrs , envChangeAddr - , envCollateral = collateral' + , envCollateral = collateral' , envUsedSomeUTxOs = mempty } - where - obtainCollateral :: IO (Maybe GYUTxO) - obtainCollateral = runMaybeT $ do - (collateralRef, toCheck) <- hoistMaybe collateral - collateralUtxo <- liftIO $ gyQueryUtxoAtTxOutRef envProviders collateralRef + where + obtainCollateral :: IO (Maybe GYUTxO) + obtainCollateral = runMaybeT $ do + (collateralRef, toCheck) <- hoistMaybe collateral + collateralUtxo <- + liftIO $ + gyQueryUtxoAtTxOutRef envProviders collateralRef >>= maybe (throwIO . GYQueryUTxOException $ GYNoUtxoAtRef collateralRef) pure - if not toCheck || (utxoValue collateralUtxo == collateralValue) then return collateralUtxo + if not toCheck || (utxoValue collateralUtxo == collateralValue) + then return collateralUtxo else hoistMaybe Nothing - diff --git a/src/GeniusYield/TxBuilder/IO/Query.hs b/src/GeniusYield/TxBuilder/IO/Query.hs index 646a5e9a..8629d894 100644 --- a/src/GeniusYield/TxBuilder/IO/Query.hs +++ b/src/GeniusYield/TxBuilder/IO/Query.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.TxBuilder.IO.Query Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 @@ -8,19 +8,18 @@ Stability : develop **INTERNAL MODULE** -} module GeniusYield.TxBuilder.IO.Query ( - GYTxQueryMonadIO, - runGYTxQueryMonadIO, - ioToQueryMonad + GYTxQueryMonadIO, + runGYTxQueryMonadIO, + ioToQueryMonad, ) where -import Control.Monad.Reader -import GHC.Stack (withFrozenCallStack) - -import GeniusYield.Imports -import GeniusYield.TxBuilder.Class -import GeniusYield.TxBuilder.Errors -import GeniusYield.Types +import Control.Monad.Reader +import GHC.Stack (withFrozenCallStack) +import GeniusYield.Imports +import GeniusYield.TxBuilder.Class +import GeniusYield.TxBuilder.Errors +import GeniusYield.Types ------------------------------------------------------------------------------- -- GY implementation @@ -28,134 +27,138 @@ import GeniusYield.Types -- | 'GYTxQueryMonad' interpretation run under IO. type role GYTxQueryMonadIO representational -newtype GYTxQueryMonadIO a = GYTxQueryMonadIO { runGYTxQueryMonadIO' :: GYTxQueryIOEnv -> IO a } - deriving ( Functor - , Applicative - , Monad - , MonadReader GYTxQueryIOEnv - , MonadRandom - ) - via ReaderT GYTxQueryIOEnv IO - -data GYTxQueryIOEnv = GYTxQueryIOEnv { envNid :: !GYNetworkId, envProviders :: !GYProviders} - --- | INTERNAL USAGE ONLY --- --- Do not expose a 'MonadIO' instance. It allows the user to do arbitrary IO within the tx monad. + +newtype GYTxQueryMonadIO a = GYTxQueryMonadIO {runGYTxQueryMonadIO' :: GYTxQueryIOEnv -> IO a} + deriving + ( Functor + , Applicative + , Monad + , MonadReader GYTxQueryIOEnv + , MonadRandom + ) + via ReaderT GYTxQueryIOEnv IO + +data GYTxQueryIOEnv = GYTxQueryIOEnv {envNid :: !GYNetworkId, envProviders :: !GYProviders} + +{- | INTERNAL USAGE ONLY + +Do not expose a 'MonadIO' instance. It allows the user to do arbitrary IO within the tx monad. +-} ioToQueryMonad :: IO a -> GYTxQueryMonadIO a ioToQueryMonad ioAct = GYTxQueryMonadIO $ const ioAct instance MonadError GYTxMonadException GYTxQueryMonadIO where - throwError = ioToQueryMonad . throwIO + throwError = ioToQueryMonad . throwIO - catchError action handler = do - env <- ask - ioToQueryMonad $ catch - (runGYTxQueryMonadIO' action env) - (\err -> handler err `runGYTxQueryMonadIO'` env) + catchError action handler = do + env <- ask + ioToQueryMonad $ + catch + (runGYTxQueryMonadIO' action env) + (\err -> handler err `runGYTxQueryMonadIO'` env) instance GYTxQueryMonad GYTxQueryMonadIO where - networkId = asks envNid - - lookupDatum h = do - logMsg mempty GYDebug $ printf "Querying Datum: %s" (show h) - providers <- asks envProviders - ioToQueryMonad $ gyLookupDatum providers h - - utxosAtAddress addr mAssetClass = do - logMsg mempty GYDebug $ printf "Querying utxo At Address: %s" addr - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxosAtAddress providers addr mAssetClass - - utxosAtAddressWithDatums addr mAssetClass = do - logMsg mempty GYDebug $ printf "Querying utxos (with datums) at address: %s" addr - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxosAtAddressWithDatums providers addr mAssetClass - - utxosAtPaymentCredential cred mAssetClass = do - logMsg mempty GYDebug $ printf "Querying UTxOs at payment credential: %s" cred - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxosAtPaymentCredential providers cred mAssetClass - - utxosAtAddresses addrs = do - logMsg mempty GYDebug $ printf "Querying utxos At Addresses: \n %s" (show addrs) - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxosAtAddresses providers addrs - - utxosAtAddressesWithDatums addrs = do - logMsg mempty GYDebug $ printf "Querying utxos (with datums) At Addresses: \n %s" (show addrs) - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxosAtAddressesWithDatums providers addrs - - utxosAtPaymentCredentialWithDatums cred mAssetClass = do - logMsg mempty GYDebug $ printf "Querying utxos (with datums) at credential: \n %s" (show cred) - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxosAtPaymentCredWithDatums providers cred mAssetClass - - utxosAtPaymentCredentials pcs = do - logMsg mempty GYDebug $ printf "Querying utxos at payment credentials: \n %s" (show pcs) - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxosAtPaymentCredentials providers pcs - - utxosAtPaymentCredentialsWithDatums pcs = do - logMsg mempty GYDebug $ printf "Querying utxos (with datums) at payment credentials: \n %s" (show pcs) - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxosAtPaymentCredsWithDatums providers pcs - - utxoRefsAtAddress addr = do - logMsg mempty GYDebug $ printf "Querying UtxoRefs At Address: %s" addr - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxoRefsAtAddress providers addr - - utxoAtTxOutRef oref = do - logMsg mempty GYDebug $ printf "Querying Utxos At TxOutRef: %s" oref - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxoAtTxOutRef providers oref - - utxosAtTxOutRefs oref = do - logMsg mempty GYDebug $ printf "Querying Utxos At TxOutRefs: %s" (show oref) - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxosAtTxOutRefs providers oref - - utxosAtTxOutRefsWithDatums orefs = do - logMsg mempty GYDebug $ printf "Querying utxos (with datums) At TxOutRefs: \n %s" (show orefs) - providers <- asks envProviders - ioToQueryMonad $ gyQueryUtxosAtTxOutRefsWithDatums providers orefs - - stakeAddressInfo saddr = do - logMsg mempty GYDebug $ printf "Querying Stake Address Info: %s" saddr - providers <- asks envProviders - ioToQueryMonad $ gyGetStakeAddressInfo providers saddr - - slotConfig = do - providers <- asks envProviders - ioToQueryMonad $ gyGetSlotConfig providers - - slotOfCurrentBlock = do - providers <- asks envProviders - ioToQueryMonad $ gyGetSlotOfCurrentBlock providers - - logMsg ns s msg = do - providers <- asks envProviders - ioToQueryMonad $ withFrozenCallStack $ gyLog providers ns s msg - - waitUntilSlot slot = do - providers <- asks envProviders - ioToQueryMonad $ gyWaitUntilSlot providers slot - - waitForNextBlock = do - providers <- asks envProviders - ioToQueryMonad $ gyWaitForNextBlock providers + networkId = asks envNid + + lookupDatum h = do + logMsg mempty GYDebug $ printf "Querying Datum: %s" (show h) + providers <- asks envProviders + ioToQueryMonad $ gyLookupDatum providers h + + utxosAtAddress addr mAssetClass = do + logMsg mempty GYDebug $ printf "Querying utxo At Address: %s" addr + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxosAtAddress providers addr mAssetClass + + utxosAtAddressWithDatums addr mAssetClass = do + logMsg mempty GYDebug $ printf "Querying utxos (with datums) at address: %s" addr + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxosAtAddressWithDatums providers addr mAssetClass + + utxosAtPaymentCredential cred mAssetClass = do + logMsg mempty GYDebug $ printf "Querying UTxOs at payment credential: %s" cred + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxosAtPaymentCredential providers cred mAssetClass + + utxosAtAddresses addrs = do + logMsg mempty GYDebug $ printf "Querying utxos At Addresses: \n %s" (show addrs) + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxosAtAddresses providers addrs + + utxosAtAddressesWithDatums addrs = do + logMsg mempty GYDebug $ printf "Querying utxos (with datums) At Addresses: \n %s" (show addrs) + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxosAtAddressesWithDatums providers addrs + + utxosAtPaymentCredentialWithDatums cred mAssetClass = do + logMsg mempty GYDebug $ printf "Querying utxos (with datums) at credential: \n %s" (show cred) + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxosAtPaymentCredWithDatums providers cred mAssetClass + + utxosAtPaymentCredentials pcs = do + logMsg mempty GYDebug $ printf "Querying utxos at payment credentials: \n %s" (show pcs) + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxosAtPaymentCredentials providers pcs + + utxosAtPaymentCredentialsWithDatums pcs = do + logMsg mempty GYDebug $ printf "Querying utxos (with datums) at payment credentials: \n %s" (show pcs) + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxosAtPaymentCredsWithDatums providers pcs + + utxoRefsAtAddress addr = do + logMsg mempty GYDebug $ printf "Querying UtxoRefs At Address: %s" addr + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxoRefsAtAddress providers addr + + utxoAtTxOutRef oref = do + logMsg mempty GYDebug $ printf "Querying Utxos At TxOutRef: %s" oref + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxoAtTxOutRef providers oref + + utxosAtTxOutRefs oref = do + logMsg mempty GYDebug $ printf "Querying Utxos At TxOutRefs: %s" (show oref) + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxosAtTxOutRefs providers oref + + utxosAtTxOutRefsWithDatums orefs = do + logMsg mempty GYDebug $ printf "Querying utxos (with datums) At TxOutRefs: \n %s" (show orefs) + providers <- asks envProviders + ioToQueryMonad $ gyQueryUtxosAtTxOutRefsWithDatums providers orefs + + stakeAddressInfo saddr = do + logMsg mempty GYDebug $ printf "Querying Stake Address Info: %s" saddr + providers <- asks envProviders + ioToQueryMonad $ gyGetStakeAddressInfo providers saddr + + slotConfig = do + providers <- asks envProviders + ioToQueryMonad $ gyGetSlotConfig providers + + slotOfCurrentBlock = do + providers <- asks envProviders + ioToQueryMonad $ gyGetSlotOfCurrentBlock providers + + logMsg ns s msg = do + providers <- asks envProviders + ioToQueryMonad $ withFrozenCallStack $ gyLog providers ns s msg + + waitUntilSlot slot = do + providers <- asks envProviders + ioToQueryMonad $ gyWaitUntilSlot providers slot + + waitForNextBlock = do + providers <- asks envProviders + ioToQueryMonad $ gyWaitForNextBlock providers instance GYTxSpecialQueryMonad GYTxQueryMonadIO where - systemStart = asks envProviders >>= ioToQueryMonad . gyGetSystemStart - eraHistory = asks envProviders >>= ioToQueryMonad . gyGetEraHistory - protocolParams = asks envProviders >>= ioToQueryMonad . gyGetProtocolParameters - stakePools = asks envProviders >>= ioToQueryMonad . gyGetStakePools - -runGYTxQueryMonadIO - :: GYNetworkId - -> GYProviders - -> GYTxQueryMonadIO a - -> IO a + systemStart = asks envProviders >>= ioToQueryMonad . gyGetSystemStart + eraHistory = asks envProviders >>= ioToQueryMonad . gyGetEraHistory + protocolParams = asks envProviders >>= ioToQueryMonad . gyGetProtocolParameters + stakePools = asks envProviders >>= ioToQueryMonad . gyGetStakePools + +runGYTxQueryMonadIO :: + GYNetworkId -> + GYProviders -> + GYTxQueryMonadIO a -> + IO a runGYTxQueryMonadIO nid providers = flip runGYTxQueryMonadIO' $ GYTxQueryIOEnv nid providers diff --git a/src/GeniusYield/TxBuilder/IO/Unsafe.hs b/src/GeniusYield/TxBuilder/IO/Unsafe.hs index 789da6d2..eed2d5d4 100644 --- a/src/GeniusYield/TxBuilder/IO/Unsafe.hs +++ b/src/GeniusYield/TxBuilder/IO/Unsafe.hs @@ -1,20 +1,23 @@ -{-| +{- | Module : GeniusYield.TxBuilder.IO.Unsafe Copyright : (c) 2024 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.TxBuilder.IO.Unsafe ( unsafeIOToQueryMonad, unsafeIOToTxBuilderMonad, ) where -import GeniusYield.TxBuilder.IO.Builder (GYTxBuilderMonadIO, - ioToTxBuilderMonad) -import GeniusYield.TxBuilder.IO.Query (GYTxQueryMonadIO, - ioToQueryMonad) +import GeniusYield.TxBuilder.IO.Builder ( + GYTxBuilderMonadIO, + ioToTxBuilderMonad, + ) +import GeniusYield.TxBuilder.IO.Query ( + GYTxQueryMonadIO, + ioToQueryMonad, + ) unsafeIOToQueryMonad :: IO a -> GYTxQueryMonadIO a unsafeIOToQueryMonad = ioToQueryMonad diff --git a/src/GeniusYield/TxBuilder/Query/Class.hs b/src/GeniusYield/TxBuilder/Query/Class.hs index 9912596b..589bfe2c 100644 --- a/src/GeniusYield/TxBuilder/Query/Class.hs +++ b/src/GeniusYield/TxBuilder/Query/Class.hs @@ -1,131 +1,129 @@ -{-| +{- | Module : GeniusYield.TxBuilder.Query.Class Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.TxBuilder.Query.Class (GYTxQueryMonad (..), GYTxSpecialQueryMonad (..), GYTxUserQueryMonad (..)) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import Control.Monad.Except (MonadError (..)) -import Control.Monad.Random (RandT, lift) -import Control.Monad.Reader (ReaderT) -import qualified Control.Monad.State.Lazy as Lazy -import qualified Control.Monad.State.Strict as Strict -import qualified Control.Monad.Writer.CPS as CPS -import qualified Control.Monad.Writer.Lazy as Lazy -import qualified Control.Monad.Writer.Strict as Strict -import qualified Data.Map.Strict as Map -import Data.Maybe (listToMaybe) -import GHC.Stack (withFrozenCallStack) - -import GeniusYield.Imports -import GeniusYield.TxBuilder.Errors -import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Control.Monad.Except (MonadError (..)) +import Control.Monad.Random (RandT, lift) +import Control.Monad.Reader (ReaderT) +import Control.Monad.State.Lazy qualified as Lazy +import Control.Monad.State.Strict qualified as Strict +import Control.Monad.Writer.CPS qualified as CPS +import Control.Monad.Writer.Lazy qualified as Lazy +import Control.Monad.Writer.Strict qualified as Strict +import Data.Map.Strict qualified as Map +import Data.Maybe (listToMaybe) +import GHC.Stack (withFrozenCallStack) + +import GeniusYield.Imports +import GeniusYield.TxBuilder.Errors +import GeniusYield.Types +import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) ------------------------------------------------------------------------------- -- Class ------------------------------------------------------------------------------- -- | Class of monads for querying chain data. -class MonadError GYTxMonadException m => GYTxQueryMonad m where - {-# MINIMAL networkId, lookupDatum, (utxoAtTxOutRef | utxosAtTxOutRefs), utxosAtAddress, utxosAtPaymentCredential, stakeAddressInfo, slotConfig, slotOfCurrentBlock, logMsg, waitUntilSlot, waitForNextBlock #-} - - -- | Get the network id - networkId :: m GYNetworkId +class (MonadError GYTxMonadException m) => GYTxQueryMonad m where + {-# MINIMAL networkId, lookupDatum, (utxoAtTxOutRef | utxosAtTxOutRefs), utxosAtAddress, utxosAtPaymentCredential, stakeAddressInfo, slotConfig, slotOfCurrentBlock, logMsg, waitUntilSlot, waitForNextBlock #-} - -- | Lookup datum by its hash. - lookupDatum :: GYDatumHash -> m (Maybe GYDatum) + -- | Get the network id + networkId :: m GYNetworkId - -- | Lookup 'GYUTxO' at 'GYTxOutRef'. - -- - utxoAtTxOutRef :: GYTxOutRef -> m (Maybe GYUTxO) - utxoAtTxOutRef ref = do - utxos <- utxosAtTxOutRefs [ref] - return $ case utxosToList utxos of - [] -> Nothing - utxo : _ -> Just utxo + -- | Lookup datum by its hash. + lookupDatum :: GYDatumHash -> m (Maybe GYDatum) - -- | Lookup UTxO at 'GYTxOutRef' with an attempt to resolve for datum. - utxoAtTxOutRefWithDatum :: GYTxOutRef -> m (Maybe (GYUTxO, Maybe GYDatum)) - utxoAtTxOutRefWithDatum ref = listToMaybe <$> utxosAtTxOutRefsWithDatums [ref] + -- | Lookup 'GYUTxO' at 'GYTxOutRef'. + utxoAtTxOutRef :: GYTxOutRef -> m (Maybe GYUTxO) + utxoAtTxOutRef ref = do + utxos <- utxosAtTxOutRefs [ref] + return $ case utxosToList utxos of + [] -> Nothing + utxo : _ -> Just utxo - -- | Lookup 'GYUTxOs' at multiple 'GYTxOutRef's at once - utxosAtTxOutRefs :: [GYTxOutRef] -> m GYUTxOs - utxosAtTxOutRefs orefs = utxosFromList <$> wither utxoAtTxOutRef orefs + -- | Lookup UTxO at 'GYTxOutRef' with an attempt to resolve for datum. + utxoAtTxOutRefWithDatum :: GYTxOutRef -> m (Maybe (GYUTxO, Maybe GYDatum)) + utxoAtTxOutRefWithDatum ref = listToMaybe <$> utxosAtTxOutRefsWithDatums [ref] - -- | Lookup UTxOs at zero or more 'GYTxOutRef' with their datums. This has a default implementation using `utxosAtTxOutRefs` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. - utxosAtTxOutRefsWithDatums :: [GYTxOutRef] -> m [(GYUTxO, Maybe GYDatum)] - utxosAtTxOutRefsWithDatums = gyQueryUtxosAtTxOutRefsWithDatumsDefault utxosAtTxOutRefs lookupDatum + -- | Lookup 'GYUTxOs' at multiple 'GYTxOutRef's at once + utxosAtTxOutRefs :: [GYTxOutRef] -> m GYUTxOs + utxosAtTxOutRefs orefs = utxosFromList <$> wither utxoAtTxOutRef orefs - -- | Lookup 'GYUTxOs' at 'GYAddress'. - utxosAtAddress :: GYAddress -> Maybe GYAssetClass -> m GYUTxOs + -- | Lookup UTxOs at zero or more 'GYTxOutRef' with their datums. This has a default implementation using `utxosAtTxOutRefs` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. + utxosAtTxOutRefsWithDatums :: [GYTxOutRef] -> m [(GYUTxO, Maybe GYDatum)] + utxosAtTxOutRefsWithDatums = gyQueryUtxosAtTxOutRefsWithDatumsDefault utxosAtTxOutRefs lookupDatum - -- | Lookup 'GYUTxO' at given 'GYAddress' with their datums. This has a default implementation using `utxosAtAddress` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. - utxosAtAddressWithDatums :: GYAddress -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] - utxosAtAddressWithDatums = gyQueryUtxosAtAddressWithDatumsDefault utxosAtAddress lookupDatum + -- | Lookup 'GYUTxOs' at 'GYAddress'. + utxosAtAddress :: GYAddress -> Maybe GYAssetClass -> m GYUTxOs - -- | Lookup 'GYUTxOs' at zero or more 'GYAddress'. - utxosAtAddresses :: [GYAddress] -> m GYUTxOs - utxosAtAddresses = foldM f mempty - where - f :: GYUTxOs -> GYAddress -> m GYUTxOs - f utxos addr = (<> utxos) <$> utxosAtAddress addr Nothing + -- | Lookup 'GYUTxO' at given 'GYAddress' with their datums. This has a default implementation using `utxosAtAddress` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. + utxosAtAddressWithDatums :: GYAddress -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] + utxosAtAddressWithDatums = gyQueryUtxosAtAddressWithDatumsDefault utxosAtAddress lookupDatum - -- | Lookup UTxOs at zero or more 'GYAddress' with their datums. This has a default implementation using `utxosAtAddresses` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. - utxosAtAddressesWithDatums :: [GYAddress] -> m [(GYUTxO, Maybe GYDatum)] - utxosAtAddressesWithDatums = gyQueryUtxosAtAddressesWithDatumsDefault utxosAtAddresses lookupDatum + -- | Lookup 'GYUTxOs' at zero or more 'GYAddress'. + utxosAtAddresses :: [GYAddress] -> m GYUTxOs + utxosAtAddresses = foldM f mempty + where + f :: GYUTxOs -> GYAddress -> m GYUTxOs + f utxos addr = (<> utxos) <$> utxosAtAddress addr Nothing - -- | Lookup the `[GYTxOutRef]`s at a `GYAddress` - utxoRefsAtAddress :: GYAddress -> m [GYTxOutRef] - utxoRefsAtAddress = fmap (Map.keys . mapUTxOs id) . flip utxosAtAddress Nothing + -- | Lookup UTxOs at zero or more 'GYAddress' with their datums. This has a default implementation using `utxosAtAddresses` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. + utxosAtAddressesWithDatums :: [GYAddress] -> m [(GYUTxO, Maybe GYDatum)] + utxosAtAddressesWithDatums = gyQueryUtxosAtAddressesWithDatumsDefault utxosAtAddresses lookupDatum - -- | Lookup 'GYUTxOs' at 'GYPaymentCredential'. - utxosAtPaymentCredential :: GYPaymentCredential -> Maybe GYAssetClass -> m GYUTxOs + -- | Lookup the `[GYTxOutRef]`s at a `GYAddress` + utxoRefsAtAddress :: GYAddress -> m [GYTxOutRef] + utxoRefsAtAddress = fmap (Map.keys . mapUTxOs id) . flip utxosAtAddress Nothing - -- | Lookup UTxOs at given 'GYPaymentCredential' with their datums. This has a default implementation using `utxosAtPaymentCredential` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. - utxosAtPaymentCredentialWithDatums :: GYPaymentCredential -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] - utxosAtPaymentCredentialWithDatums = gyQueryUtxosAtPaymentCredWithDatumsDefault utxosAtPaymentCredential lookupDatum + -- | Lookup 'GYUTxOs' at 'GYPaymentCredential'. + utxosAtPaymentCredential :: GYPaymentCredential -> Maybe GYAssetClass -> m GYUTxOs - -- | Lookup 'GYUTxOs' at zero or more 'GYPaymentCredential'. - utxosAtPaymentCredentials :: [GYPaymentCredential] -> m GYUTxOs - utxosAtPaymentCredentials = foldM f mempty - where - f :: GYUTxOs -> GYPaymentCredential -> m GYUTxOs - f utxos paymentCred = (<> utxos) <$> utxosAtPaymentCredential paymentCred Nothing + -- | Lookup UTxOs at given 'GYPaymentCredential' with their datums. This has a default implementation using `utxosAtPaymentCredential` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. + utxosAtPaymentCredentialWithDatums :: GYPaymentCredential -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] + utxosAtPaymentCredentialWithDatums = gyQueryUtxosAtPaymentCredWithDatumsDefault utxosAtPaymentCredential lookupDatum - -- | Lookup UTxOs at zero or more 'GYPaymentCredential' with their datums. This has a default implementation using `utxosAtPaymentCredentials` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. - utxosAtPaymentCredentialsWithDatums :: [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)] - utxosAtPaymentCredentialsWithDatums = gyQueryUtxosAtPaymentCredsWithDatumsDefault utxosAtPaymentCredentials lookupDatum + -- | Lookup 'GYUTxOs' at zero or more 'GYPaymentCredential'. + utxosAtPaymentCredentials :: [GYPaymentCredential] -> m GYUTxOs + utxosAtPaymentCredentials = foldM f mempty + where + f :: GYUTxOs -> GYPaymentCredential -> m GYUTxOs + f utxos paymentCred = (<> utxos) <$> utxosAtPaymentCredential paymentCred Nothing - -- | Obtain delegation information for a stake address. Note that in case stake address is not registered, this function should return `Nothing`. - stakeAddressInfo :: GYStakeAddress -> m (Maybe GYStakeAddressInfo) + -- | Lookup UTxOs at zero or more 'GYPaymentCredential' with their datums. This has a default implementation using `utxosAtPaymentCredentials` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. + utxosAtPaymentCredentialsWithDatums :: [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)] + utxosAtPaymentCredentialsWithDatums = gyQueryUtxosAtPaymentCredsWithDatumsDefault utxosAtPaymentCredentials lookupDatum - {- | Obtain the slot config for the network. + -- | Obtain delegation information for a stake address. Note that in case stake address is not registered, this function should return `Nothing`. + stakeAddressInfo :: GYStakeAddress -> m (Maybe GYStakeAddressInfo) - Implementations using era history to create slot config may raise 'GYEraSummariesToSlotConfigError'. - -} - slotConfig :: m GYSlotConfig + -- | Obtain the slot config for the network. + -- + -- Implementations using era history to create slot config may raise 'GYEraSummariesToSlotConfigError'. + slotConfig :: m GYSlotConfig - -- | This is expected to give the slot of the latest block. We say "expected" as we cache the result for 5 seconds, that is to say, suppose slot was cached at time @T@, now if query for current block's slot comes within time duration @(T, T + 5)@, then we'll return the cached slot but if say, query happened at time @(T + 5, T + 21)@ where @21@ was taken as an arbitrary number above 5, then we'll query the chain tip and get the slot of the latest block seen by the provider and then store it in our cache, thus new cached value would be served for requests coming within time interval of @(T + 21, T + 26)@. - -- - -- __NOTE:__ It's behaviour is slightly different, solely for our plutus simple model provider where it actually returns the value of the @currentSlot@ variable maintained inside plutus simple model library. - slotOfCurrentBlock :: m GYSlot + -- | This is expected to give the slot of the latest block. We say "expected" as we cache the result for 5 seconds, that is to say, suppose slot was cached at time @T@, now if query for current block's slot comes within time duration @(T, T + 5)@, then we'll return the cached slot but if say, query happened at time @(T + 5, T + 21)@ where @21@ was taken as an arbitrary number above 5, then we'll query the chain tip and get the slot of the latest block seen by the provider and then store it in our cache, thus new cached value would be served for requests coming within time interval of @(T + 21, T + 26)@. + -- + -- __NOTE:__ It's behaviour is slightly different, solely for our plutus simple model provider where it actually returns the value of the @currentSlot@ variable maintained inside plutus simple model library. + slotOfCurrentBlock :: m GYSlot - -- | Log a message with specified namespace and severity. - logMsg :: HasCallStack => GYLogNamespace -> GYLogSeverity -> String -> m () + -- | Log a message with specified namespace and severity. + logMsg :: (HasCallStack) => GYLogNamespace -> GYLogSeverity -> String -> m () - -- | Wait until the chain tip is at least the given slot number, returning it's slot. - waitUntilSlot :: GYSlot -> m GYSlot + -- | Wait until the chain tip is at least the given slot number, returning it's slot. + waitUntilSlot :: GYSlot -> m GYSlot - -- | Wait until the chain tip is at the next block, return it's slot. - waitForNextBlock :: m GYSlot + -- | Wait until the chain tip is at the next block, return it's slot. + waitForNextBlock :: m GYSlot -- | Class of monads for querying special chain data. + {- Note [Necessity of 'GYTxSpecialQueryMonad' and transaction building as a class method] The only purpose of 'GYTxSpecialQueryMonad' is to provide necessary information for building @@ -138,104 +136,104 @@ to decide where to draw the line regarding the interface. Our transaction buildi coin selection strategy, parallel transactions, chaining transactions etc. Should all this really be included under the class method in question? -} -class GYTxQueryMonad m => GYTxSpecialQueryMonad m where - systemStart :: m Api.SystemStart - eraHistory :: m Api.EraHistory - protocolParams :: m ApiProtocolParameters - stakePools :: m (Set Api.S.PoolId) +class (GYTxQueryMonad m) => GYTxSpecialQueryMonad m where + systemStart :: m Api.SystemStart + eraHistory :: m Api.EraHistory + protocolParams :: m ApiProtocolParameters + stakePools :: m (Set Api.S.PoolId) -- | Class of monads for querying as a user. -class GYTxQueryMonad m => GYTxUserQueryMonad m where - -- | Get your own address(es). - ownAddresses :: m [GYAddress] +class (GYTxQueryMonad m) => GYTxUserQueryMonad m where + -- | Get your own address(es). + ownAddresses :: m [GYAddress] - -- | Get own change address. - ownChangeAddress :: m GYAddress + -- | Get own change address. + ownChangeAddress :: m GYAddress - -- | Get own collateral utxo. - ownCollateral :: m (Maybe GYUTxO) + -- | Get own collateral utxo. + ownCollateral :: m (Maybe GYUTxO) - -- | Get available own UTxOs that can be operated upon. - availableUTxOs :: m GYUTxOs + -- | Get available own UTxOs that can be operated upon. + availableUTxOs :: m GYUTxOs - -- | Return some unspent transaction output translatable to the given language corresponding to the script in question. - -- - -- /Law:/ Must return the different values. - someUTxO :: PlutusVersion -> m GYTxOutRef + -- | Return some unspent transaction output translatable to the given language corresponding to the script in question. + -- + -- /Law:/ Must return the different values. + someUTxO :: PlutusVersion -> m GYTxOutRef ------------------------------------------------------------------------------- -- Instances for useful transformers. ------------------------------------------------------------------------------- -instance GYTxQueryMonad m => GYTxQueryMonad (RandT g m) where - networkId = lift networkId - lookupDatum = lift . lookupDatum - utxoAtTxOutRef = lift . utxoAtTxOutRef - utxosAtTxOutRefs = lift . utxosAtTxOutRefs - utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums - utxosAtAddress addr = lift . utxosAtAddress addr - utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr - utxosAtAddresses = lift . utxosAtAddresses - utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums - utxoRefsAtAddress = lift . utxoRefsAtAddress - utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc - utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc - utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials - utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums - stakeAddressInfo = lift . stakeAddressInfo - slotConfig = lift slotConfig - slotOfCurrentBlock = lift slotOfCurrentBlock - logMsg ns s = withFrozenCallStack $ lift . logMsg ns s - waitUntilSlot = lift . waitUntilSlot - waitForNextBlock = lift waitForNextBlock - -instance GYTxUserQueryMonad m => GYTxUserQueryMonad (RandT g m) where - ownAddresses = lift ownAddresses - ownChangeAddress = lift ownChangeAddress - ownCollateral = lift ownCollateral - availableUTxOs = lift availableUTxOs - someUTxO = lift . someUTxO - -instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (RandT g m) where - systemStart = lift systemStart - eraHistory = lift eraHistory - protocolParams = lift protocolParams - stakePools = lift stakePools - -instance GYTxQueryMonad m => GYTxQueryMonad (ReaderT env m) where - networkId = lift networkId - lookupDatum = lift . lookupDatum - utxoAtTxOutRef = lift . utxoAtTxOutRef - utxosAtTxOutRefs = lift . utxosAtTxOutRefs - utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums - utxosAtAddress addr = lift . utxosAtAddress addr - utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr - utxosAtAddresses = lift . utxosAtAddresses - utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums - utxoRefsAtAddress = lift . utxoRefsAtAddress - utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc - utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc - utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials - utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums - stakeAddressInfo = lift . stakeAddressInfo - slotConfig = lift slotConfig - slotOfCurrentBlock = lift slotOfCurrentBlock - logMsg ns s = withFrozenCallStack $ lift . logMsg ns s - waitUntilSlot = lift . waitUntilSlot - waitForNextBlock = lift waitForNextBlock - -instance GYTxUserQueryMonad m => GYTxUserQueryMonad (ReaderT env m) where - ownAddresses = lift ownAddresses - ownChangeAddress = lift ownChangeAddress - ownCollateral = lift ownCollateral - availableUTxOs = lift availableUTxOs - someUTxO = lift . someUTxO - -instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (ReaderT env m) where - systemStart = lift systemStart - eraHistory = lift eraHistory - protocolParams = lift protocolParams - stakePools = lift stakePools +instance (GYTxQueryMonad m) => GYTxQueryMonad (RandT g m) where + networkId = lift networkId + lookupDatum = lift . lookupDatum + utxoAtTxOutRef = lift . utxoAtTxOutRef + utxosAtTxOutRefs = lift . utxosAtTxOutRefs + utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums + utxosAtAddress addr = lift . utxosAtAddress addr + utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr + utxosAtAddresses = lift . utxosAtAddresses + utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums + utxoRefsAtAddress = lift . utxoRefsAtAddress + utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc + utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc + utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials + utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums + stakeAddressInfo = lift . stakeAddressInfo + slotConfig = lift slotConfig + slotOfCurrentBlock = lift slotOfCurrentBlock + logMsg ns s = withFrozenCallStack $ lift . logMsg ns s + waitUntilSlot = lift . waitUntilSlot + waitForNextBlock = lift waitForNextBlock + +instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (RandT g m) where + ownAddresses = lift ownAddresses + ownChangeAddress = lift ownChangeAddress + ownCollateral = lift ownCollateral + availableUTxOs = lift availableUTxOs + someUTxO = lift . someUTxO + +instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (RandT g m) where + systemStart = lift systemStart + eraHistory = lift eraHistory + protocolParams = lift protocolParams + stakePools = lift stakePools + +instance (GYTxQueryMonad m) => GYTxQueryMonad (ReaderT env m) where + networkId = lift networkId + lookupDatum = lift . lookupDatum + utxoAtTxOutRef = lift . utxoAtTxOutRef + utxosAtTxOutRefs = lift . utxosAtTxOutRefs + utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums + utxosAtAddress addr = lift . utxosAtAddress addr + utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr + utxosAtAddresses = lift . utxosAtAddresses + utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums + utxoRefsAtAddress = lift . utxoRefsAtAddress + utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc + utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc + utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials + utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums + stakeAddressInfo = lift . stakeAddressInfo + slotConfig = lift slotConfig + slotOfCurrentBlock = lift slotOfCurrentBlock + logMsg ns s = withFrozenCallStack $ lift . logMsg ns s + waitUntilSlot = lift . waitUntilSlot + waitForNextBlock = lift waitForNextBlock + +instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (ReaderT env m) where + ownAddresses = lift ownAddresses + ownChangeAddress = lift ownChangeAddress + ownCollateral = lift ownCollateral + availableUTxOs = lift availableUTxOs + someUTxO = lift . someUTxO + +instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (ReaderT env m) where + systemStart = lift systemStart + eraHistory = lift eraHistory + protocolParams = lift protocolParams + stakePools = lift stakePools ------------------------------------------------------------------------------- -- Instances for less useful transformers, provided for completeness. @@ -243,7 +241,6 @@ instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (ReaderT env m) where -- See: https://github.com/haskell-effectful/effectful/blob/master/transformers.md ------------------------------------------------------------------------------- - {- Note [MonadError on GYTxQueryMonad and ExceptT] ExceptT instances are omitted since the MonadError requirement for GYTxQueryMonad @@ -264,177 +261,177 @@ system will suffice (do NOT use free(er) monad like ones). This will trivialize entire problem. -} -instance GYTxQueryMonad m => GYTxQueryMonad (Strict.StateT s m) where - networkId = lift networkId - lookupDatum = lift . lookupDatum - utxoAtTxOutRef = lift . utxoAtTxOutRef - utxosAtTxOutRefs = lift . utxosAtTxOutRefs - utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums - utxosAtAddress addr = lift . utxosAtAddress addr - utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr - utxosAtAddresses = lift . utxosAtAddresses - utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums - utxoRefsAtAddress = lift . utxoRefsAtAddress - utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc - utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc - utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials - utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums - stakeAddressInfo = lift . stakeAddressInfo - slotConfig = lift slotConfig - slotOfCurrentBlock = lift slotOfCurrentBlock - logMsg ns s = withFrozenCallStack $ lift . logMsg ns s - waitUntilSlot = lift . waitUntilSlot - waitForNextBlock = lift waitForNextBlock - -instance GYTxUserQueryMonad m => GYTxUserQueryMonad (Strict.StateT s m) where - ownAddresses = lift ownAddresses - ownChangeAddress = lift ownChangeAddress - ownCollateral = lift ownCollateral - availableUTxOs = lift availableUTxOs - someUTxO = lift . someUTxO - -instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (Strict.StateT s m) where - systemStart = lift systemStart - eraHistory = lift eraHistory - protocolParams = lift protocolParams - stakePools = lift stakePools - -instance GYTxQueryMonad m => GYTxQueryMonad (Lazy.StateT s m) where - networkId = lift networkId - lookupDatum = lift . lookupDatum - utxoAtTxOutRef = lift . utxoAtTxOutRef - utxosAtTxOutRefs = lift . utxosAtTxOutRefs - utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums - utxosAtAddress addr = lift . utxosAtAddress addr - utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr - utxosAtAddresses = lift . utxosAtAddresses - utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums - utxoRefsAtAddress = lift . utxoRefsAtAddress - utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc - utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc - utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials - utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums - stakeAddressInfo = lift . stakeAddressInfo - slotConfig = lift slotConfig - slotOfCurrentBlock = lift slotOfCurrentBlock - logMsg ns s = withFrozenCallStack $ lift . logMsg ns s - waitUntilSlot = lift . waitUntilSlot - waitForNextBlock = lift waitForNextBlock - -instance GYTxUserQueryMonad m => GYTxUserQueryMonad (Lazy.StateT s m) where - ownAddresses = lift ownAddresses - ownChangeAddress = lift ownChangeAddress - ownCollateral = lift ownCollateral - availableUTxOs = lift availableUTxOs - someUTxO = lift . someUTxO - -instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (Lazy.StateT s m) where - systemStart = lift systemStart - eraHistory = lift eraHistory - protocolParams = lift protocolParams - stakePools = lift stakePools +instance (GYTxQueryMonad m) => GYTxQueryMonad (Strict.StateT s m) where + networkId = lift networkId + lookupDatum = lift . lookupDatum + utxoAtTxOutRef = lift . utxoAtTxOutRef + utxosAtTxOutRefs = lift . utxosAtTxOutRefs + utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums + utxosAtAddress addr = lift . utxosAtAddress addr + utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr + utxosAtAddresses = lift . utxosAtAddresses + utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums + utxoRefsAtAddress = lift . utxoRefsAtAddress + utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc + utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc + utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials + utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums + stakeAddressInfo = lift . stakeAddressInfo + slotConfig = lift slotConfig + slotOfCurrentBlock = lift slotOfCurrentBlock + logMsg ns s = withFrozenCallStack $ lift . logMsg ns s + waitUntilSlot = lift . waitUntilSlot + waitForNextBlock = lift waitForNextBlock + +instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (Strict.StateT s m) where + ownAddresses = lift ownAddresses + ownChangeAddress = lift ownChangeAddress + ownCollateral = lift ownCollateral + availableUTxOs = lift availableUTxOs + someUTxO = lift . someUTxO + +instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (Strict.StateT s m) where + systemStart = lift systemStart + eraHistory = lift eraHistory + protocolParams = lift protocolParams + stakePools = lift stakePools + +instance (GYTxQueryMonad m) => GYTxQueryMonad (Lazy.StateT s m) where + networkId = lift networkId + lookupDatum = lift . lookupDatum + utxoAtTxOutRef = lift . utxoAtTxOutRef + utxosAtTxOutRefs = lift . utxosAtTxOutRefs + utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums + utxosAtAddress addr = lift . utxosAtAddress addr + utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr + utxosAtAddresses = lift . utxosAtAddresses + utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums + utxoRefsAtAddress = lift . utxoRefsAtAddress + utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc + utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc + utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials + utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums + stakeAddressInfo = lift . stakeAddressInfo + slotConfig = lift slotConfig + slotOfCurrentBlock = lift slotOfCurrentBlock + logMsg ns s = withFrozenCallStack $ lift . logMsg ns s + waitUntilSlot = lift . waitUntilSlot + waitForNextBlock = lift waitForNextBlock + +instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (Lazy.StateT s m) where + ownAddresses = lift ownAddresses + ownChangeAddress = lift ownChangeAddress + ownCollateral = lift ownCollateral + availableUTxOs = lift availableUTxOs + someUTxO = lift . someUTxO + +instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (Lazy.StateT s m) where + systemStart = lift systemStart + eraHistory = lift eraHistory + protocolParams = lift protocolParams + stakePools = lift stakePools instance (GYTxQueryMonad m, Monoid w) => GYTxQueryMonad (CPS.WriterT w m) where - networkId = lift networkId - lookupDatum = lift . lookupDatum - utxoAtTxOutRef = lift . utxoAtTxOutRef - utxosAtTxOutRefs = lift . utxosAtTxOutRefs - utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums - utxosAtAddress addr = lift . utxosAtAddress addr - utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr - utxosAtAddresses = lift . utxosAtAddresses - utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums - utxoRefsAtAddress = lift . utxoRefsAtAddress - utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc - utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc - utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials - utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums - stakeAddressInfo = lift . stakeAddressInfo - slotConfig = lift slotConfig - slotOfCurrentBlock = lift slotOfCurrentBlock - logMsg ns s = withFrozenCallStack $ lift . logMsg ns s - waitUntilSlot = lift . waitUntilSlot - waitForNextBlock = lift waitForNextBlock + networkId = lift networkId + lookupDatum = lift . lookupDatum + utxoAtTxOutRef = lift . utxoAtTxOutRef + utxosAtTxOutRefs = lift . utxosAtTxOutRefs + utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums + utxosAtAddress addr = lift . utxosAtAddress addr + utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr + utxosAtAddresses = lift . utxosAtAddresses + utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums + utxoRefsAtAddress = lift . utxoRefsAtAddress + utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc + utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc + utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials + utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums + stakeAddressInfo = lift . stakeAddressInfo + slotConfig = lift slotConfig + slotOfCurrentBlock = lift slotOfCurrentBlock + logMsg ns s = withFrozenCallStack $ lift . logMsg ns s + waitUntilSlot = lift . waitUntilSlot + waitForNextBlock = lift waitForNextBlock instance (GYTxUserQueryMonad m, Monoid w) => GYTxUserQueryMonad (CPS.WriterT w m) where - ownAddresses = lift ownAddresses - ownChangeAddress = lift ownChangeAddress - ownCollateral = lift ownCollateral - availableUTxOs = lift availableUTxOs - someUTxO = lift . someUTxO + ownAddresses = lift ownAddresses + ownChangeAddress = lift ownChangeAddress + ownCollateral = lift ownCollateral + availableUTxOs = lift availableUTxOs + someUTxO = lift . someUTxO instance (GYTxSpecialQueryMonad m, Monoid w) => GYTxSpecialQueryMonad (CPS.WriterT w m) where - systemStart = lift systemStart - eraHistory = lift eraHistory - protocolParams = lift protocolParams - stakePools = lift stakePools + systemStart = lift systemStart + eraHistory = lift eraHistory + protocolParams = lift protocolParams + stakePools = lift stakePools instance (GYTxQueryMonad m, Monoid w) => GYTxQueryMonad (Strict.WriterT w m) where - networkId = lift networkId - lookupDatum = lift . lookupDatum - utxoAtTxOutRef = lift . utxoAtTxOutRef - utxosAtTxOutRefs = lift . utxosAtTxOutRefs - utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums - utxosAtAddress addr = lift . utxosAtAddress addr - utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr - utxosAtAddresses = lift . utxosAtAddresses - utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums - utxoRefsAtAddress = lift . utxoRefsAtAddress - utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc - utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc - utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials - utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums - stakeAddressInfo = lift . stakeAddressInfo - slotConfig = lift slotConfig - slotOfCurrentBlock = lift slotOfCurrentBlock - logMsg ns s = withFrozenCallStack $ lift . logMsg ns s - waitUntilSlot = lift . waitUntilSlot - waitForNextBlock = lift waitForNextBlock + networkId = lift networkId + lookupDatum = lift . lookupDatum + utxoAtTxOutRef = lift . utxoAtTxOutRef + utxosAtTxOutRefs = lift . utxosAtTxOutRefs + utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums + utxosAtAddress addr = lift . utxosAtAddress addr + utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr + utxosAtAddresses = lift . utxosAtAddresses + utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums + utxoRefsAtAddress = lift . utxoRefsAtAddress + utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc + utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc + utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials + utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums + stakeAddressInfo = lift . stakeAddressInfo + slotConfig = lift slotConfig + slotOfCurrentBlock = lift slotOfCurrentBlock + logMsg ns s = withFrozenCallStack $ lift . logMsg ns s + waitUntilSlot = lift . waitUntilSlot + waitForNextBlock = lift waitForNextBlock instance (GYTxUserQueryMonad m, Monoid w) => GYTxUserQueryMonad (Strict.WriterT w m) where - ownAddresses = lift ownAddresses - ownChangeAddress = lift ownChangeAddress - ownCollateral = lift ownCollateral - availableUTxOs = lift availableUTxOs - someUTxO = lift . someUTxO + ownAddresses = lift ownAddresses + ownChangeAddress = lift ownChangeAddress + ownCollateral = lift ownCollateral + availableUTxOs = lift availableUTxOs + someUTxO = lift . someUTxO instance (GYTxSpecialQueryMonad m, Monoid w) => GYTxSpecialQueryMonad (Strict.WriterT w m) where - systemStart = lift systemStart - eraHistory = lift eraHistory - protocolParams = lift protocolParams - stakePools = lift stakePools + systemStart = lift systemStart + eraHistory = lift eraHistory + protocolParams = lift protocolParams + stakePools = lift stakePools instance (GYTxQueryMonad m, Monoid w) => GYTxQueryMonad (Lazy.WriterT w m) where - networkId = lift networkId - lookupDatum = lift . lookupDatum - utxoAtTxOutRef = lift . utxoAtTxOutRef - utxosAtTxOutRefs = lift . utxosAtTxOutRefs - utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums - utxosAtAddress addr = lift . utxosAtAddress addr - utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr - utxosAtAddresses = lift . utxosAtAddresses - utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums - utxoRefsAtAddress = lift . utxoRefsAtAddress - utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc - utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc - utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials - utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums - stakeAddressInfo = lift . stakeAddressInfo - slotConfig = lift slotConfig - slotOfCurrentBlock = lift slotOfCurrentBlock - logMsg ns s = withFrozenCallStack $ lift . logMsg ns s - waitUntilSlot = lift . waitUntilSlot - waitForNextBlock = lift waitForNextBlock + networkId = lift networkId + lookupDatum = lift . lookupDatum + utxoAtTxOutRef = lift . utxoAtTxOutRef + utxosAtTxOutRefs = lift . utxosAtTxOutRefs + utxosAtTxOutRefsWithDatums = lift . utxosAtTxOutRefsWithDatums + utxosAtAddress addr = lift . utxosAtAddress addr + utxosAtAddressWithDatums addr = lift . utxosAtAddressWithDatums addr + utxosAtAddresses = lift . utxosAtAddresses + utxosAtAddressesWithDatums = lift . utxosAtAddressesWithDatums + utxoRefsAtAddress = lift . utxoRefsAtAddress + utxosAtPaymentCredential pc = lift . utxosAtPaymentCredential pc + utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc + utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials + utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums + stakeAddressInfo = lift . stakeAddressInfo + slotConfig = lift slotConfig + slotOfCurrentBlock = lift slotOfCurrentBlock + logMsg ns s = withFrozenCallStack $ lift . logMsg ns s + waitUntilSlot = lift . waitUntilSlot + waitForNextBlock = lift waitForNextBlock instance (GYTxUserQueryMonad m, Monoid w) => GYTxUserQueryMonad (Lazy.WriterT w m) where - ownAddresses = lift ownAddresses - ownChangeAddress = lift ownChangeAddress - ownCollateral = lift ownCollateral - availableUTxOs = lift availableUTxOs - someUTxO = lift . someUTxO + ownAddresses = lift ownAddresses + ownChangeAddress = lift ownChangeAddress + ownCollateral = lift ownCollateral + availableUTxOs = lift availableUTxOs + someUTxO = lift . someUTxO instance (GYTxSpecialQueryMonad m, Monoid w) => GYTxSpecialQueryMonad (Lazy.WriterT w m) where - systemStart = lift systemStart - eraHistory = lift eraHistory - protocolParams = lift protocolParams - stakePools = lift stakePools + systemStart = lift systemStart + eraHistory = lift eraHistory + protocolParams = lift protocolParams + stakePools = lift stakePools diff --git a/src/GeniusYield/TxBuilder/User.hs b/src/GeniusYield/TxBuilder/User.hs index 9a8cb0f4..2c48b244 100644 --- a/src/GeniusYield/TxBuilder/User.hs +++ b/src/GeniusYield/TxBuilder/User.hs @@ -1,57 +1,59 @@ {-# LANGUAGE PatternSynonyms #-} module GeniusYield.TxBuilder.User ( - User (..), - UserCollateral (..), - pattern User', - userPkh, - userPaymentPkh, - userStakePkh, - userVKey, - userPaymentVKey, - userPaymentSKey', - userStakeSKey', - userStakeVKey, - userCollateralDumb, - userAddresses', - userAddr, + User (..), + UserCollateral (..), + pattern User', + userPkh, + userPaymentPkh, + userStakePkh, + userVKey, + userPaymentVKey, + userPaymentSKey', + userStakeSKey', + userStakeVKey, + userCollateralDumb, + userAddresses', + userAddr, ) where -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE -import GeniusYield.Imports -import GeniusYield.Types.Address (GYAddress) -import GeniusYield.Types.Key -import GeniusYield.Types.Key.Class (ToShelleyWitnessSigningKey (toShelleyWitnessSigningKey)) -import GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash) -import GeniusYield.Types.PubKeyHash (AsPubKeyHash(toPubKeyHash), GYPubKeyHash) -import GeniusYield.Types.StakeKeyHash (GYStakeKeyHash) -import GeniusYield.Types.TxOutRef (GYTxOutRef) +import GeniusYield.Imports +import GeniusYield.Types.Address (GYAddress) +import GeniusYield.Types.Key +import GeniusYield.Types.Key.Class (ToShelleyWitnessSigningKey (toShelleyWitnessSigningKey)) +import GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash) +import GeniusYield.Types.PubKeyHash (AsPubKeyHash (toPubKeyHash), GYPubKeyHash) +import GeniusYield.Types.StakeKeyHash (GYStakeKeyHash) +import GeniusYield.Types.TxOutRef (GYTxOutRef) -- | Information on a the designated collateral to use. data UserCollateral = UserCollateral - { userCollateralRef :: GYTxOutRef - , userCollateralCheck :: Bool - -- ^ If `False` then the given `GYTxOutRef` will be used and reserved as collateral. - -- If `True`, then collateral will only be used and reserved, if value in the given UTxO is exactly 5 ada. - } deriving stock (Eq, Show) + { userCollateralRef :: GYTxOutRef + , userCollateralCheck :: Bool + -- ^ If `False` then the given `GYTxOutRef` will be used and reserved as collateral. + -- If `True`, then collateral will only be used and reserved, if value in the given UTxO is exactly 5 ada. + } + deriving stock (Eq, Show) -- | Note: When signing using 'ToShelleyWitnessSigningKey' instance, it only uses the payment signing key. data User = User - { userPaymentSKey :: !GYPaymentSigningKey - , userStakeSKey :: !(Maybe GYStakeSigningKey) - , userAddresses :: !(NonEmpty GYAddress) - , userChangeAddress :: !GYAddress - , userCollateral :: Maybe UserCollateral - } deriving stock (Eq, Show) + { userPaymentSKey :: !GYPaymentSigningKey + , userStakeSKey :: !(Maybe GYStakeSigningKey) + , userAddresses :: !(NonEmpty GYAddress) + , userChangeAddress :: !GYAddress + , userCollateral :: Maybe UserCollateral + } + deriving stock (Eq, Show) instance Ord User where compare = compare `on` userChangeAddress -- | This only takes the payment signing key, not the stake key. instance ToShelleyWitnessSigningKey User where - toShelleyWitnessSigningKey = toShelleyWitnessSigningKey . userPaymentSKey + toShelleyWitnessSigningKey = toShelleyWitnessSigningKey . userPaymentSKey {-# DEPRECATED userVKey "Use userPaymentVKey." #-} userVKey :: User -> GYPaymentVerificationKey @@ -73,24 +75,26 @@ userStakePkh :: User -> Maybe GYStakeKeyHash userStakePkh = fmap (stakeKeyHash . stakeVerificationKey) . userStakeSKey userCollateralDumb :: User -> Maybe (GYTxOutRef, Bool) -userCollateralDumb User{userCollateral} = - (\UserCollateral {userCollateralRef, userCollateralCheck} -> (userCollateralRef, userCollateralCheck)) <$> userCollateral +userCollateralDumb User {userCollateral} = + (\UserCollateral {userCollateralRef, userCollateralCheck} -> (userCollateralRef, userCollateralCheck)) <$> userCollateral userAddresses' :: User -> [GYAddress] userAddresses' = NE.toList . userAddresses pattern User' :: GYPaymentSigningKey -> Maybe GYStakeSigningKey -> GYAddress -> User -pattern User' { userPaymentSKey', userStakeSKey', userAddr } <- User +pattern User' {userPaymentSKey', userStakeSKey', userAddr} <- + User + { userPaymentSKey = userPaymentSKey' + , userStakeSKey = userStakeSKey' + , userAddresses = (NE.head -> userAddr) + } + where + User' userPaymentSKey' userStakeSKey' userAddr = + User { userPaymentSKey = userPaymentSKey' - , userStakeSKey = userStakeSKey' - , userAddresses = (NE.head -> userAddr) + , userStakeSKey = userStakeSKey' + , userAddresses = NE.singleton userAddr + , userChangeAddress = userAddr + , userCollateral = Nothing } - where - User' userPaymentSKey' userStakeSKey' userAddr = User - { userPaymentSKey = userPaymentSKey' - , userStakeSKey = userStakeSKey' - , userAddresses = NE.singleton userAddr - , userChangeAddress = userAddr - , userCollateral = Nothing - } {-# COMPLETE User' #-} diff --git a/src/GeniusYield/Types.hs b/src/GeniusYield/Types.hs index 580910e6..5064f19e 100644 --- a/src/GeniusYield/Types.hs +++ b/src/GeniusYield/Types.hs @@ -1,51 +1,49 @@ -{-| +{- | Module : GeniusYield.Types Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Types - ( Natural - , module X +module GeniusYield.Types ( + Natural, + module X, ) where -import Numeric.Natural (Natural) - -import GeniusYield.Types.Ada as X -import GeniusYield.Types.Address as X -import GeniusYield.Types.Certificate as X -import GeniusYield.Types.Credential as X -import GeniusYield.Types.Datum as X -import GeniusYield.Types.Era as X -import GeniusYield.Types.Key as X -import GeniusYield.Types.Ledger as X -import GeniusYield.Types.Logging as X -import GeniusYield.Types.Natural as X -import GeniusYield.Types.NetworkId as X -import GeniusYield.Types.OpenApi as X -import GeniusYield.Types.PaymentKeyHash as X -import GeniusYield.Types.PlutusVersion as X -import GeniusYield.Types.Providers as X -import GeniusYield.Types.PubKeyHash as X -import GeniusYield.Types.Rational as X -import GeniusYield.Types.Redeemer as X -import GeniusYield.Types.Script as X -import GeniusYield.Types.Slot as X -import GeniusYield.Types.SlotConfig as X -import GeniusYield.Types.StakeAddressInfo as X -import GeniusYield.Types.StakeKeyHash as X -import GeniusYield.Types.StakePoolId as X -import GeniusYield.Types.Time as X -import GeniusYield.Types.Tx as X -import GeniusYield.Types.TxBody as X -import GeniusYield.Types.TxCert as X -import GeniusYield.Types.TxIn as X -import GeniusYield.Types.TxMetadata as X -import GeniusYield.Types.TxOut as X -import GeniusYield.Types.TxOutRef as X -import GeniusYield.Types.TxWdrl as X -import GeniusYield.Types.UTxO as X -import GeniusYield.Types.Value as X -import GeniusYield.Types.Wallet as X +import GeniusYield.Types.Ada as X +import GeniusYield.Types.Address as X +import GeniusYield.Types.Certificate as X +import GeniusYield.Types.Credential as X +import GeniusYield.Types.Datum as X +import GeniusYield.Types.Era as X +import GeniusYield.Types.Key as X +import GeniusYield.Types.Ledger as X +import GeniusYield.Types.Logging as X +import GeniusYield.Types.Natural as X +import GeniusYield.Types.NetworkId as X +import GeniusYield.Types.OpenApi as X +import GeniusYield.Types.PaymentKeyHash as X +import GeniusYield.Types.PlutusVersion as X +import GeniusYield.Types.Providers as X +import GeniusYield.Types.PubKeyHash as X +import GeniusYield.Types.Rational as X +import GeniusYield.Types.Redeemer as X +import GeniusYield.Types.Script as X +import GeniusYield.Types.Slot as X +import GeniusYield.Types.SlotConfig as X +import GeniusYield.Types.StakeAddressInfo as X +import GeniusYield.Types.StakeKeyHash as X +import GeniusYield.Types.StakePoolId as X +import GeniusYield.Types.Time as X +import GeniusYield.Types.Tx as X +import GeniusYield.Types.TxBody as X +import GeniusYield.Types.TxCert as X +import GeniusYield.Types.TxIn as X +import GeniusYield.Types.TxMetadata as X +import GeniusYield.Types.TxOut as X +import GeniusYield.Types.TxOutRef as X +import GeniusYield.Types.TxWdrl as X +import GeniusYield.Types.UTxO as X +import GeniusYield.Types.Value as X +import GeniusYield.Types.Wallet as X +import Numeric.Natural (Natural) diff --git a/src/GeniusYield/Types/Ada.hs b/src/GeniusYield/Types/Ada.hs index cd4d6d79..83685200 100644 --- a/src/GeniusYield/Types/Ada.hs +++ b/src/GeniusYield/Types/Ada.hs @@ -1,26 +1,25 @@ -{-| +{- | Module : GeniusYield.Types.Ada Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Ada ( - Ada (Ada) - , adaSymbol - , adaToken - , toLovelace - , toValue - , fromValue - , lovelaceOf - , lovelaceValueOf + Ada (Ada), + adaSymbol, + adaToken, + toLovelace, + toValue, + fromValue, + lovelaceOf, + lovelaceValueOf, ) where -import Data.Fixed (Fixed (MkFixed), Micro) +import Data.Fixed (Fixed (MkFixed), Micro) -import PlutusLedgerApi.V1.Value (Value, adaSymbol, adaToken) -import qualified PlutusLedgerApi.V1.Value as Value +import PlutusLedgerApi.V1.Value (Value, adaSymbol, adaToken) +import PlutusLedgerApi.V1.Value qualified as Value -- | Ada represented with a 'Micro' value. newtype Ada = Ada Micro diff --git a/src/GeniusYield/Types/Address.hs b/src/GeniusYield/Types/Address.hs index c0ffcdd2..d304fb19 100644 --- a/src/GeniusYield/Types/Address.hs +++ b/src/GeniusYield/Types/Address.hs @@ -1,150 +1,161 @@ -{-| +{- | Module : GeniusYield.Types.Address Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Address ( - GYAddress, - addressToApi, - addressToApi', - addressFromApi, - addressFromApi', - addressToPlutus, - addressFromPlutus, - addressToPaymentCredential, - addressToStakeCredential, - addressFromPubKeyHash, - addressFromPaymentKeyHash, - addressFromValidator, - addressFromCredential, - addressFromValidatorHash, - addressFromScriptHash, - addressFromSimpleScript, - addressToText, - addressFromTextMaybe, - unsafeAddressFromText, - addressToPubKeyHash, - addressToValidatorHash, - -- * newtype wrapper - GYAddressBech32, - addressToBech32, - addressFromBech32, - -- * Stake address. - GYStakeAddress, - stakeAddressFromApi, - stakeAddressToApi, - stakeAddressFromTextMaybe, - unsafeStakeAddressFromText, - stakeAddressToText, - stakeAddressCredential, - stakeAddressToCredential, - stakeAddressFromCredential, - GYStakeKeyHashString, - stakeKeyFromAddress, - -- * newtype wrapper - GYStakeAddressBech32, - stakeAddressToBech32, - stakeAddressFromBech32 + GYAddress, + addressToApi, + addressToApi', + addressFromApi, + addressFromApi', + addressToPlutus, + addressFromPlutus, + addressToPaymentCredential, + addressToStakeCredential, + addressFromPubKeyHash, + addressFromPaymentKeyHash, + addressFromValidator, + addressFromCredential, + addressFromValidatorHash, + addressFromScriptHash, + addressFromSimpleScript, + addressToText, + addressFromTextMaybe, + unsafeAddressFromText, + addressToPubKeyHash, + addressToValidatorHash, + + -- * newtype wrapper + GYAddressBech32, + addressToBech32, + addressFromBech32, + + -- * Stake address. + GYStakeAddress, + stakeAddressFromApi, + stakeAddressToApi, + stakeAddressFromTextMaybe, + unsafeStakeAddressFromText, + stakeAddressToText, + stakeAddressCredential, + stakeAddressToCredential, + stakeAddressFromCredential, + GYStakeKeyHashString, + stakeKeyFromAddress, + + -- * newtype wrapper + GYStakeAddressBech32, + stakeAddressToBech32, + stakeAddressFromBech32, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Byron as Api.B -import qualified Cardano.Api.Shelley as Api.S -import Cardano.Chain.Common (addrToBase58) -import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Ledger.BaseTypes as Ledger -import qualified Cardano.Ledger.Credential as Ledger -import qualified Cardano.Ledger.Crypto as Ledger -import qualified Cardano.Ledger.Hashes as Ledger -import qualified Cardano.Ledger.Keys as Ledger -import Control.Lens ((?~)) -import qualified Data.Aeson.Types as Aeson -import qualified Data.Csv as Csv -import Data.Hashable (Hashable (..)) -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Swagger.Lens () -import qualified Data.Text as Text -import qualified Data.Text.Encoding as TE -import qualified Data.Vector as Vector -import Data.Word (Word64) -import qualified Database.PostgreSQL.Simple as PQ -import qualified Database.PostgreSQL.Simple.FromField as PQ (FromField (..), - returnError) -import qualified Database.PostgreSQL.Simple.ToField as PQ -import qualified PlutusLedgerApi.V1.Address as Plutus -import qualified PlutusLedgerApi.V1.Credential as Plutus -import qualified PlutusLedgerApi.V1.Crypto as Plutus -import qualified PlutusLedgerApi.V1.Scripts as Plutus -import qualified PlutusTx.Builtins.Internal as Plutus -import qualified PlutusTx.Prelude as PlutusTx -import qualified Text.Printf as Printf -import qualified Web.HttpApiData as Web - -import GeniusYield.Imports -import GeniusYield.Types.Credential (GYPaymentCredential, - GYStakeCredential, - paymentCredentialFromApi, - paymentCredentialToApi, - stakeCredentialFromApi, - stakeCredentialToApi, - stakeCredentialToHexText) -import GeniusYield.Types.Era -import GeniusYield.Types.Ledger -import GeniusYield.Types.NetworkId -import GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash, - paymentKeyHashToApi) -import GeniusYield.Types.PubKeyHash -import GeniusYield.Types.Script - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Cardano.Api as Api --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import qualified Data.Csv as Csv --- >>> import GeniusYield.Types.NetworkId --- >>> import qualified Text.Printf as Printf --- >>> import qualified Web.HttpApiData as Web --- --- >>> let addr = unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" --- >>> let addrScript = unsafeAddressFromText "addr_test1wqtcz4vq80zxr3dskdcuw7wtfq0vwssd7rrpnnvcvrjhp5sx7leew" --- >>> let addrByron1 = unsafeAddressFromText "Ae2tdPwUPEYwFx4dmJheyNPPYXtvHbJLeCaA96o6Y2iiUL18cAt7AizN2zG" --- >>> let addrByron2 = unsafeAddressFromText "DdzFFzCqrhsn2RLCG6ogRgDxUUpkM3yNqyaSB3jq9YuuX1zARCJerbCoghG4PGiqwR1h8o4Jk7Mjgu3qhNixep5QAA8QgG9Dp2oE4eit" --- >>> let stakeAddr = unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" +import Cardano.Api qualified as Api +import Cardano.Api.Byron qualified as Api.B +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Chain.Common (addrToBase58) +import Cardano.Crypto.Hash.Class qualified as Crypto +import Cardano.Ledger.BaseTypes qualified as Ledger +import Cardano.Ledger.Credential qualified as Ledger +import Cardano.Ledger.Crypto qualified as Ledger +import Cardano.Ledger.Hashes qualified as Ledger +import Cardano.Ledger.Keys qualified as Ledger +import Control.Lens ((?~)) +import Data.Aeson.Types qualified as Aeson +import Data.Csv qualified as Csv +import Data.Hashable (Hashable (..)) +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Swagger.Lens qualified () +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import Data.Vector qualified as Vector +import Data.Word (Word64) +import Database.PostgreSQL.Simple qualified as PQ +import Database.PostgreSQL.Simple.FromField qualified as PQ ( + FromField (..), + returnError, + ) +import Database.PostgreSQL.Simple.ToField qualified as PQ +import PlutusLedgerApi.V1.Address qualified as Plutus +import PlutusLedgerApi.V1.Credential qualified as Plutus +import PlutusLedgerApi.V1.Crypto qualified as Plutus +import PlutusLedgerApi.V1.Scripts qualified as Plutus +import PlutusTx.Builtins.Internal qualified as Plutus +import PlutusTx.Prelude qualified as PlutusTx +import Text.Printf qualified as Printf +import Web.HttpApiData qualified as Web + +import GeniusYield.Imports +import GeniusYield.Types.Credential ( + GYPaymentCredential, + GYStakeCredential, + paymentCredentialFromApi, + paymentCredentialToApi, + stakeCredentialFromApi, + stakeCredentialToApi, + stakeCredentialToHexText, + ) +import GeniusYield.Types.Era +import GeniusYield.Types.Ledger +import GeniusYield.Types.NetworkId +import GeniusYield.Types.PaymentKeyHash ( + GYPaymentKeyHash, + paymentKeyHashToApi, + ) +import GeniusYield.Types.PubKeyHash +import GeniusYield.Types.Script + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Cardano.Api as Api +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import qualified Data.Csv as Csv +>>> import GeniusYield.Types.NetworkId +>>> import qualified Text.Printf as Printf +>>> import qualified Web.HttpApiData as Web + +>>> let addr = unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" +>>> let addrScript = unsafeAddressFromText "addr_test1wqtcz4vq80zxr3dskdcuw7wtfq0vwssd7rrpnnvcvrjhp5sx7leew" +>>> let addrByron1 = unsafeAddressFromText "Ae2tdPwUPEYwFx4dmJheyNPPYXtvHbJLeCaA96o6Y2iiUL18cAt7AizN2zG" +>>> let addrByron2 = unsafeAddressFromText "DdzFFzCqrhsn2RLCG6ogRgDxUUpkM3yNqyaSB3jq9YuuX1zARCJerbCoghG4PGiqwR1h8o4Jk7Mjgu3qhNixep5QAA8QgG9Dp2oE4eit" +>>> let stakeAddr = unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" +-} -- | Addresses on the blockchain. newtype GYAddress = GYAddress Api.AddressAny - deriving (Eq, Ord, Generic) + deriving (Eq, Ord, Generic) --- | --- --- >>> let addr = unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" +{- | + +>>> let addr = unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" +-} -- >>> show addr -- addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5 -- instance Show GYAddress where - showsPrec d addr = showParen (d > 10) $ - showString "unsafeAddressFromText " . - showsPrec 11 (addressToText addr) + showsPrec d addr = + showParen (d > 10) $ + showString "unsafeAddressFromText " + . showsPrec 11 (addressToText addr) instance Hashable GYAddress where - hashWithSalt salt (GYAddress addr) = hashWithSalt salt (Api.serialiseToRawBytes addr) + hashWithSalt salt (GYAddress addr) = hashWithSalt salt (Api.serialiseToRawBytes addr) --- | --- --- >>> addressToApi addr --- AddressShelley (ShelleyAddress Testnet (KeyHashObj (KeyHash {unKeyHash = "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616"})))) --- >>> addressToApi addrByron1 --- AddressByron (ByronAddress (Address {addrRoot = 04865e42d2373addbebd5d2acf81c760c848970142889f7ee763091b, addrAttributes = Attributes { data_ = AddrAttributes {aaVKDerivationPath = Nothing, aaNetworkMagic = NetworkMainOrStage} }, addrType = ATVerKey})) --- >>> addressToApi addrByron2 --- AddressByron (ByronAddress (Address {addrRoot = 3f04ff82d3008d3a4f3d2be7d66141dcbcbda74d6a805e463895b72a, addrAttributes = Attributes { data_ = AddrAttributes {aaVKDerivationPath = Just (HDAddressPayload {getHDAddressPayload = "\251C\"a\SUB\209\210M\245S\200S\144\160\190\237y[s\176\148\n3!\DLE\147\141\168"}), aaNetworkMagic = NetworkMainOrStage} }, addrType = ATVerKey})) --- +{- | + +>>> addressToApi addr +AddressShelley (ShelleyAddress Testnet (KeyHashObj (KeyHash {unKeyHash = "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616"})))) +>>> addressToApi addrByron1 +AddressByron (ByronAddress (Address {addrRoot = 04865e42d2373addbebd5d2acf81c760c848970142889f7ee763091b, addrAttributes = Attributes { data_ = AddrAttributes {aaVKDerivationPath = Nothing, aaNetworkMagic = NetworkMainOrStage} }, addrType = ATVerKey})) +>>> addressToApi addrByron2 +AddressByron (ByronAddress (Address {addrRoot = 3f04ff82d3008d3a4f3d2be7d66141dcbcbda74d6a805e463895b72a, addrAttributes = Attributes { data_ = AddrAttributes {aaVKDerivationPath = Just (HDAddressPayload {getHDAddressPayload = "\251C\"a\SUB\209\210M\245S\200S\144\160\190\237y[s\176\148\n3!\DLE\147\141\168"}), aaNetworkMagic = NetworkMainOrStage} }, addrType = ATVerKey})) +-} addressToApi :: GYAddress -> Api.AddressAny addressToApi = coerce @@ -153,7 +164,7 @@ addressToApi' = coerce addrAnyToConwayEra -- not exported addrAnyToConwayEra :: Api.AddressAny -> Api.AddressInEra ApiEra -addrAnyToConwayEra (Api.AddressByron addr) = Api.AddressInEra Api.ByronAddressInAnyEra addr +addrAnyToConwayEra (Api.AddressByron addr) = Api.AddressInEra Api.ByronAddressInAnyEra addr addrAnyToConwayEra (Api.AddressShelley addr) = Api.AddressInEra (Api.ShelleyAddressInEra Api.ShelleyBasedEraConway) addr addressFromApi :: Api.AddressAny -> GYAddress @@ -164,22 +175,22 @@ addressFromApi' = coerce addressInEraToAny -- not exported addressInEraToAny :: Api.AddressInEra era -> Api.AddressAny -addressInEraToAny (Api.AddressInEra Api.ByronAddressInAnyEra a) = Api.AddressByron a +addressInEraToAny (Api.AddressInEra Api.ByronAddressInAnyEra a) = Api.AddressByron a addressInEraToAny (Api.AddressInEra (Api.ShelleyAddressInEra _) a) = Api.AddressShelley a ------------------------------------------------------------------------------- -- Plutus conversions ------------------------------------------------------------------------------- --- | --- --- >>> addressToPlutus addr --- Address {addressCredential = PubKeyCredential e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d, addressStakingCredential = Just (StakingHash (PubKeyCredential 1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616))} --- +{- | + +>>> addressToPlutus addr +Address {addressCredential = PubKeyCredential e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d, addressStakingCredential = Just (StakingHash (PubKeyCredential 1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616))} +-} addressToPlutus :: GYAddress -> Plutus.Address addressToPlutus addr = case addressToApi addr of - Api.AddressByron addr' -> byronAddressToPlutus addr' - Api.AddressShelley addr' -> shelleyAddressToPlutus addr' + Api.AddressByron addr' -> byronAddressToPlutus addr' + Api.AddressShelley addr' -> shelleyAddressToPlutus addr' -- Lookup Ledger.Tx.CardanoAPI module in plutus-ledger. byronAddressToPlutus :: Api.S.Address Api.S.ByronAddr -> Plutus.Address @@ -190,42 +201,42 @@ byronAddressToPlutus (Api.B.ByronAddress addr) = Plutus.Address plutusCredential shelleyAddressToPlutus :: Api.Address Api.ShelleyAddr -> Plutus.Address shelleyAddressToPlutus (Api.S.ShelleyAddress _network credential stake) = - Plutus.Address - (shelleyCredentialToPlutus (Api.S.fromShelleyPaymentCredential credential)) - (shelleyStakeRefToPlutus (Api.S.fromShelleyStakeReference stake)) + Plutus.Address + (shelleyCredentialToPlutus (Api.S.fromShelleyPaymentCredential credential)) + (shelleyStakeRefToPlutus (Api.S.fromShelleyStakeReference stake)) shelleyCredentialToPlutus :: Api.S.PaymentCredential -> Plutus.Credential -shelleyCredentialToPlutus (Api.S.PaymentCredentialByKey x) = Plutus.PubKeyCredential $ Plutus.PubKeyHash $ PlutusTx.toBuiltin $ Api.serialiseToRawBytes x +shelleyCredentialToPlutus (Api.S.PaymentCredentialByKey x) = Plutus.PubKeyCredential $ Plutus.PubKeyHash $ PlutusTx.toBuiltin $ Api.serialiseToRawBytes x shelleyCredentialToPlutus (Api.S.PaymentCredentialByScript x) = Plutus.ScriptCredential . Plutus.ScriptHash . PlutusTx.toBuiltin . Api.serialiseToRawBytes $ x shelleyStakeRefToPlutus :: Api.S.StakeAddressReference -> Maybe Plutus.StakingCredential -shelleyStakeRefToPlutus Api.S.NoStakeAddress = Nothing -shelleyStakeRefToPlutus Api.StakeAddressByPointer {} = Nothing +shelleyStakeRefToPlutus Api.S.NoStakeAddress = Nothing +shelleyStakeRefToPlutus Api.StakeAddressByPointer {} = Nothing shelleyStakeRefToPlutus (Api.StakeAddressByValue stakeCredential) = Just $ Plutus.StakingHash $ fromCardanoStakeCredential stakeCredential fromCardanoStakeCredential :: Api.StakeCredential -> Plutus.Credential -fromCardanoStakeCredential (Api.S.StakeCredentialByKey x) = Plutus.PubKeyCredential $ Plutus.PubKeyHash $ PlutusTx.toBuiltin $ Api.serialiseToRawBytes x +fromCardanoStakeCredential (Api.S.StakeCredentialByKey x) = Plutus.PubKeyCredential $ Plutus.PubKeyHash $ PlutusTx.toBuiltin $ Api.serialiseToRawBytes x fromCardanoStakeCredential (Api.S.StakeCredentialByScript x) = Plutus.ScriptCredential $ Plutus.ScriptHash $ PlutusTx.toBuiltin $ Api.serialiseToRawBytes x --- | Used to inject wallet pubkeyhashes into addresses. --- --- >>> import GeniusYield.Types.NetworkId --- --- >>> addressFromPlutus GYTestnetPreprod $ addressToPlutus addr --- Right (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") --- +{- | Used to inject wallet pubkeyhashes into addresses. + +>>> import GeniusYield.Types.NetworkId + +>>> addressFromPlutus GYTestnetPreprod $ addressToPlutus addr +Right (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") +-} addressFromPlutus :: GYNetworkId -> Plutus.Address -> Either PlutusToCardanoError GYAddress addressFromPlutus nid addr = - maybe - (Left $ UnknownPlutusToCardanoError $ Text.pack $ "addressFromPlutus: " <> show addr) - (Right . GYAddress . Api.S.AddressShelley) + maybe + (Left $ UnknownPlutusToCardanoError $ Text.pack $ "addressFromPlutus: " <> show addr) + (Right . GYAddress . Api.S.AddressShelley) $ Api.S.ShelleyAddress nid' <$> paymentCredential <*> stakeReference where nid' :: Ledger.Network nid' = networkIdToLedger nid credential :: Plutus.Credential -> Maybe (Ledger.Credential kr Ledger.StandardCrypto) - credential (Plutus.PubKeyCredential (Plutus.PubKeyHash (Plutus.BuiltinByteString bs))) = Ledger.KeyHashObj . Ledger.KeyHash <$> Crypto.hashFromBytes bs + credential (Plutus.PubKeyCredential (Plutus.PubKeyHash (Plutus.BuiltinByteString bs))) = Ledger.KeyHashObj . Ledger.KeyHash <$> Crypto.hashFromBytes bs credential (Plutus.ScriptCredential (Plutus.ScriptHash (Plutus.BuiltinByteString bs))) = Ledger.ScriptHashObj . Ledger.ScriptHash <$> Crypto.hashFromBytes bs paymentCredential :: Maybe (Ledger.PaymentCredential Ledger.StandardCrypto) @@ -233,29 +244,30 @@ addressFromPlutus nid addr = stakeReference :: Maybe (Ledger.StakeReference Ledger.StandardCrypto) stakeReference = case Plutus.addressStakingCredential addr of - Nothing -> Just Ledger.StakeRefNull - Just (Plutus.StakingHash c) -> Ledger.StakeRefBase <$> credential c - Just (Plutus.StakingPtr x y z) -> Ledger.StakeRefPtr <$> ptr x y z + Nothing -> Just Ledger.StakeRefNull + Just (Plutus.StakingHash c) -> Ledger.StakeRefBase <$> credential c + Just (Plutus.StakingPtr x y z) -> Ledger.StakeRefPtr <$> ptr x y z ptr :: Integer -> Integer -> Integer -> Maybe Ledger.Ptr ptr x y z = Ledger.Ptr <$> coerce integerToWord64 x <*> coerce integerToWord64 y <*> coerce integerToWord64 z integerToWord64 :: Integer -> Maybe Word64 integerToWord64 n - | n < 0 = Nothing - | n > toInteger (maxBound @Word64) = Nothing - | otherwise = Just $ fromInteger n - --- | If an address is a shelley address, then we'll return payment credential wrapped in `Just`, `Nothing` otherwise. --- --- >>> addressToPaymentCredential addr --- Just (GYPaymentCredentialByKey (GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d")) --- >>> addressToPaymentCredential addrScript --- Just (GYPaymentCredentialByScript (GYScriptHash "178155803bc461c5b0b371c779cb481ec7420df0c619cd9860e570d2")) --- >>> addressToPaymentCredential addrByron1 --- Nothing --- >>> addressToPaymentCredential addrByron2 --- Nothing + | n < 0 = Nothing + | n > toInteger (maxBound @Word64) = Nothing + | otherwise = Just $ fromInteger n + +{- | If an address is a shelley address, then we'll return payment credential wrapped in `Just`, `Nothing` otherwise. + +>>> addressToPaymentCredential addr +Just (GYPaymentCredentialByKey (GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d")) +>>> addressToPaymentCredential addrScript +Just (GYPaymentCredentialByScript (GYScriptHash "178155803bc461c5b0b371c779cb481ec7420df0c619cd9860e570d2")) +>>> addressToPaymentCredential addrByron1 +Nothing +>>> addressToPaymentCredential addrByron2 +Nothing +-} addressToPaymentCredential :: GYAddress -> Maybe GYPaymentCredential addressToPaymentCredential (addressToApi -> Api.AddressShelley addr) = Just $ getShelleyAddressPaymentCredential addr addressToPaymentCredential _byron = Nothing @@ -264,18 +276,17 @@ addressToPaymentCredential _byron = Nothing getShelleyAddressPaymentCredential :: Api.S.Address Api.ShelleyAddr -> GYPaymentCredential getShelleyAddressPaymentCredential (Api.S.ShelleyAddress _network credential _stake) = Api.S.fromShelleyPaymentCredential credential & paymentCredentialFromApi +{- | If an address is a shelley address, then we'll return stake credential, if present, wrapped in `Just` and `Nothing` otherwise. --- | If an address is a shelley address, then we'll return stake credential, if present, wrapped in `Just` and `Nothing` otherwise. --- --- >>> addressToStakeCredential addr --- Just (GYStakeCredentialByKey (GYStakeKeyHash "1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616")) --- >>> addressToStakeCredential addrScript --- Nothing --- >>> addressToStakeCredential addrByron1 --- Nothing --- >>> addressToStakeCredential addrByron2 --- Nothing --- +>>> addressToStakeCredential addr +Just (GYStakeCredentialByKey (GYStakeKeyHash "1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616")) +>>> addressToStakeCredential addrScript +Nothing +>>> addressToStakeCredential addrByron1 +Nothing +>>> addressToStakeCredential addrByron2 +Nothing +-} addressToStakeCredential :: GYAddress -> Maybe GYStakeCredential addressToStakeCredential (addressToApi -> Api.AddressShelley addr) = getShelleyAddressStakeCredential addr addressToStakeCredential _byron = Nothing @@ -285,33 +296,39 @@ getShelleyAddressStakeCredential :: Api.S.Address Api.ShelleyAddr -> Maybe GYSta getShelleyAddressStakeCredential (Api.S.ShelleyAddress _network _payment stake) = case Api.S.fromShelleyStakeReference stake of Api.S.StakeAddressByValue stakeCred -> Just $ stakeCredentialFromApi stakeCred - _ -> Nothing + _ -> Nothing --- | Create address from 'GYPubKeyHash'. --- --- /note:/ no stake credential. --- +{- | Create address from 'GYPubKeyHash'. + +/note:/ no stake credential. +-} {-# DEPRECATED addressFromPubKeyHash "Use addressFromPaymentKeyHash." #-} addressFromPubKeyHash :: GYNetworkId -> GYPubKeyHash -> GYAddress -addressFromPubKeyHash nid pkh = addressFromApi $ Api.AddressShelley $ Api.S.makeShelleyAddress - (networkIdToApi nid) - (Api.S.PaymentCredentialByKey (pubKeyHashToApi pkh)) - Api.S.NoStakeAddress +addressFromPubKeyHash nid pkh = + addressFromApi $ + Api.AddressShelley $ + Api.S.makeShelleyAddress + (networkIdToApi nid) + (Api.S.PaymentCredentialByKey (pubKeyHashToApi pkh)) + Api.S.NoStakeAddress --- | Create address from 'GYPaymentKeyHash'. --- --- /note:/ no stake credential. --- +{- | Create address from 'GYPaymentKeyHash'. + +/note:/ no stake credential. +-} addressFromPaymentKeyHash :: GYNetworkId -> GYPaymentKeyHash -> GYAddress -addressFromPaymentKeyHash nid pkh = addressFromApi $ Api.AddressShelley $ Api.S.makeShelleyAddress - (networkIdToApi nid) - (Api.S.PaymentCredentialByKey (paymentKeyHashToApi pkh)) - Api.S.NoStakeAddress +addressFromPaymentKeyHash nid pkh = + addressFromApi $ + Api.AddressShelley $ + Api.S.makeShelleyAddress + (networkIdToApi nid) + (Api.S.PaymentCredentialByKey (paymentKeyHashToApi pkh)) + Api.S.NoStakeAddress --- | Create address from 'GYValidatorHash'. --- --- /note:/ no stake credential. --- +{- | Create address from 'GYValidatorHash'. + +/note:/ no stake credential. +-} addressFromValidatorHash :: GYNetworkId -> GYValidatorHash -> GYAddress addressFromValidatorHash nid vh = addressFromScriptHash' nid (validatorHashToApi vh) @@ -320,10 +337,13 @@ addressFromScriptHash :: GYNetworkId -> GYScriptHash -> GYAddress addressFromScriptHash nid sh = addressFromScriptHash' nid (scriptHashToApi sh) addressFromScriptHash' :: GYNetworkId -> Api.ScriptHash -> GYAddress -addressFromScriptHash' nid sh = addressFromApi $ Api.AddressShelley $ Api.S.makeShelleyAddress - (networkIdToApi nid) - (Api.S.PaymentCredentialByScript sh) - Api.S.NoStakeAddress +addressFromScriptHash' nid sh = + addressFromApi $ + Api.AddressShelley $ + Api.S.makeShelleyAddress + (networkIdToApi nid) + (Api.S.PaymentCredentialByScript sh) + Api.S.NoStakeAddress -- | Create address from `GYSimpleScript`. addressFromSimpleScript :: GYNetworkId -> GYSimpleScript -> GYAddress @@ -331,31 +351,36 @@ addressFromSimpleScript nid script = addressFromScriptHash' nid (hashSimpleScrip -- | Create an address from payment & optionally, a stake credential. addressFromCredential :: GYNetworkId -> GYPaymentCredential -> Maybe GYStakeCredential -> GYAddress -addressFromCredential nid pc sc = addressFromApi $ Api.AddressShelley $ Api.S.makeShelleyAddress - (networkIdToApi nid) - (paymentCredentialToApi pc) - (maybe Api.S.NoStakeAddress (Api.S.StakeAddressByValue . stakeCredentialToApi) sc) +addressFromCredential nid pc sc = + addressFromApi $ + Api.AddressShelley $ + Api.S.makeShelleyAddress + (networkIdToApi nid) + (paymentCredentialToApi pc) + (maybe Api.S.NoStakeAddress (Api.S.StakeAddressByValue . stakeCredentialToApi) sc) --- | Create address from 'GYValidator'. --- --- /note:/ no stake credential. --- +{- | Create address from 'GYValidator'. + +/note:/ no stake credential. +-} addressFromValidator :: GYNetworkId -> GYValidator v -> GYAddress addressFromValidator nid v = addressFromValidatorHash nid (validatorHash v) addressToPubKeyHash :: GYAddress -> Maybe GYPubKeyHash addressToPubKeyHash (GYAddress (Api.AddressByron (Api.B.ByronAddress _addr))) = - Nothing -- It's not clear what to do with these, and whether GY should support Byron addresses at all (as owners of pools) -addressToPubKeyHash (GYAddress (Api.AddressShelley (Api.S.ShelleyAddress _network credential _stake))) = f (Api.S.fromShelleyPaymentCredential credential) where + Nothing -- It's not clear what to do with these, and whether GY should support Byron addresses at all (as owners of pools) +addressToPubKeyHash (GYAddress (Api.AddressShelley (Api.S.ShelleyAddress _network credential _stake))) = f (Api.S.fromShelleyPaymentCredential credential) + where f :: Api.S.PaymentCredential -> Maybe GYPubKeyHash - f (Api.S.PaymentCredentialByKey h) = Just (pubKeyHashFromApi h) + f (Api.S.PaymentCredentialByKey h) = Just (pubKeyHashFromApi h) f (Api.S.PaymentCredentialByScript _) = Nothing addressToValidatorHash :: GYAddress -> Maybe GYValidatorHash addressToValidatorHash (GYAddress (Api.AddressByron _)) = Nothing -addressToValidatorHash (GYAddress (Api.AddressShelley (Api.S.ShelleyAddress _network credential _stake))) = f (Api.S.fromShelleyPaymentCredential credential) where +addressToValidatorHash (GYAddress (Api.AddressShelley (Api.S.ShelleyAddress _network credential _stake))) = f (Api.S.fromShelleyPaymentCredential credential) + where f :: Api.S.PaymentCredential -> Maybe GYValidatorHash - f (Api.S.PaymentCredentialByKey _) = Nothing + f (Api.S.PaymentCredentialByKey _) = Nothing f (Api.S.PaymentCredentialByScript h) = Just (validatorHashFromApi h) ------------------------------------------------------------------------------- @@ -366,7 +391,8 @@ addressFromTextMaybe :: Text.Text -> Maybe GYAddress addressFromTextMaybe = coerce (Api.deserialiseAddress Api.AsAddressAny) unsafeAddressFromText :: Text.Text -> GYAddress -unsafeAddressFromText t = fromMaybe +unsafeAddressFromText t = + fromMaybe (error $ "Not an address: " ++ show t) (addressFromTextMaybe t) @@ -377,132 +403,144 @@ addressToText (GYAddress addr) = Api.serialiseAddress addr -- Text.Printf ------------------------------------------------------------------------------- --- | This instance is using for logging --- --- >>> Printf.printf "addr = %s" addr --- addr = addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5 +{- | This instance is using for logging + +>>> Printf.printf "addr = %s" addr +addr = addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5 +-} instance Printf.PrintfArg GYAddress where - formatArg addr = Printf.formatArg (addressToText addr) + formatArg addr = Printf.formatArg (addressToText addr) ------------------------------------------------------------------------------- -- aeson ------------------------------------------------------------------------------- --- | In JSON context addresses are represented in hex. --- --- >>> Aeson.decode @GYAddress "\"00e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616\"" --- Just (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") --- +{- | In JSON context addresses are represented in hex. + +>>> Aeson.decode @GYAddress "\"00e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616\"" +Just (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") +-} instance Aeson.FromJSON GYAddress where - parseJSON = Aeson.withText "GYAddress" $ \t -> - case Web.parseUrlPiece t of - Left err -> fail $ Text.unpack err - Right addr -> return addr + parseJSON = Aeson.withText "GYAddress" $ \t -> + case Web.parseUrlPiece t of + Left err -> fail $ Text.unpack err + Right addr -> return addr --- | --- --- >>> LBS8.putStrLn $ Aeson.encode addr --- "00e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode addr +"00e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616" +-} instance Aeson.ToJSON GYAddress where - toJSON = Aeson.String . Web.toUrlPiece + toJSON = Aeson.String . Web.toUrlPiece ------------------------------------------------------------------------------- -- http-api-data ------------------------------------------------------------------------------- --- | In an HTTP context, addresses are represented in hex. --- --- >>> Web.toUrlPiece addr --- "00e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616" +{- | In an HTTP context, addresses are represented in hex. + +>>> Web.toUrlPiece addr +"00e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616" +-} instance Web.ToHttpApiData GYAddress where - toUrlPiece (GYAddress addr) = TE.decodeLatin1 (Api.serialiseToRawBytesHex addr) + toUrlPiece (GYAddress addr) = TE.decodeLatin1 (Api.serialiseToRawBytesHex addr) --- | --- --- >>> Web.parseUrlPiece @GYAddress "00e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616" --- Right (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") --- --- >>> Web.parseUrlPiece @GYAddress "00" --- Left "Not an address: 00; Reason: RawBytesHexErrorRawBytesDecodeFail \"00\" AddressAny (SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise AddressAny\"})" --- +{- | + +>>> Web.parseUrlPiece @GYAddress "00e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616" +Right (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") + +>>> Web.parseUrlPiece @GYAddress "00" +Left "Not an address: 00; Reason: RawBytesHexErrorRawBytesDecodeFail \"00\" AddressAny (SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise AddressAny\"})" +-} instance Web.FromHttpApiData GYAddress where - parseUrlPiece t = case Api.deserialiseFromRawBytesHex Api.AsAddressAny (TE.encodeUtf8 t) of - Right addr -> Right (GYAddress addr) - Left x -> Left $ "Not an address: " <> t <> "; Reason: " <> Text.pack (show x) + parseUrlPiece t = case Api.deserialiseFromRawBytesHex Api.AsAddressAny (TE.encodeUtf8 t) of + Right addr -> Right (GYAddress addr) + Left x -> Left $ "Not an address: " <> t <> "; Reason: " <> Text.pack (show x) ------------------------------------------------------------------------------- -- CSV ------------------------------------------------------------------------------- --- | --- --- >>> Csv.toField $ unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" --- "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" --- +{- | + +>>> Csv.toField $ unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" +"addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" +-} instance Csv.ToField GYAddress where - toField = encodeUtf8 . addressToText + toField = encodeUtf8 . addressToText --- | --- --- >>> Csv.runParser $ Csv.parseField @GYAddress "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" --- Right (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") --- --- >>> Csv.runParser $ Csv.parseField @GYAddress "not an address" --- Left "Not an address: not an address" --- +{- | + +>>> Csv.runParser $ Csv.parseField @GYAddress "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" +Right (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") + +>>> Csv.runParser $ Csv.parseField @GYAddress "not an address" +Left "Not an address: not an address" +-} instance Csv.FromField GYAddress where - parseField = either (fail . Text.unpack) (return . addressFromBech32) . Web.parseUrlPiece . decodeUtf8Lenient + parseField = either (fail . Text.unpack) (return . addressFromBech32) . Web.parseUrlPiece . decodeUtf8Lenient --- | --- --- >>> Csv.encodeWith (Csv.defaultEncodeOptions {Csv.encUseCrLf = False}) [unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5"] --- "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5\n" --- +{- | + +>>> Csv.encodeWith (Csv.defaultEncodeOptions {Csv.encUseCrLf = False}) [unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5"] +"addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5\n" +-} instance Csv.ToRecord GYAddress where - toRecord = Vector.singleton . Csv.toField + toRecord = Vector.singleton . Csv.toField --- | --- --- >>> Csv.decode @GYAddress Csv.NoHeader "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5\n" --- Right [unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5"] --- --- >>> Csv.decode @GYAddress Csv.NoHeader "not an address\n" --- Left "parse error (Failed reading: conversion error: Not an address: not an address) at \"\\n\"" --- --- >>> Csv.decode @GYAddress Csv.NoHeader "not, an, address\n" --- Left "parse error (Failed reading: conversion error: expected exactly one field, but got: [\"not\",\" an\",\" address\"]) at \"\\n\"" --- +{- | + +>>> Csv.decode @GYAddress Csv.NoHeader "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5\n" +Right [unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5"] + +>>> Csv.decode @GYAddress Csv.NoHeader "not an address\n" +Left "parse error (Failed reading: conversion error: Not an address: not an address) at \"\\n\"" + +>>> Csv.decode @GYAddress Csv.NoHeader "not, an, address\n" +Left "parse error (Failed reading: conversion error: expected exactly one field, but got: [\"not\",\" an\",\" address\"]) at \"\\n\"" +-} instance Csv.FromRecord GYAddress where - parseRecord v = case Vector.toList v of - [bs] -> Csv.parseField bs - _ -> fail $ printf "expected exactly one field, but got: %s" $ show v + parseRecord v = case Vector.toList v of + [bs] -> Csv.parseField bs + _ -> fail $ printf "expected exactly one field, but got: %s" $ show v ------------------------------------------------------------------------------- -- swagger schema ------------------------------------------------------------------------------- instance Swagger.ToParamSchema GYAddress where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "cbor hex" - & Swagger.maxLength ?~ 114 - & Swagger.minLength ?~ 114 + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "cbor hex" + & Swagger.maxLength + ?~ 114 + & Swagger.minLength + ?~ 114 instance Swagger.ToSchema GYAddress where - declareNamedSchema _ = pure $ Swagger.named "GYAddress" $ Swagger.paramSchemaToSchema (Proxy @GYAddress) - & Swagger.description ?~ "An address, serialised as CBOR." - & Swagger.example ?~ toJSON ("00e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616" :: Text) + declareNamedSchema _ = + pure $ + Swagger.named "GYAddress" $ + Swagger.paramSchemaToSchema (Proxy @GYAddress) + & Swagger.description + ?~ "An address, serialised as CBOR." + & Swagger.example + ?~ toJSON ("00e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616" :: Text) ------------------------------------------------------------------------------- -- newtype ------------------------------------------------------------------------------- --- | 'GYAddressBech32' which uses "bech32" format --- --- >>> Web.toUrlPiece $ addressToBech32 addr --- "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" --- +{- | 'GYAddressBech32' which uses "bech32" format + +>>> Web.toUrlPiece $ addressToBech32 addr +"addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" +-} newtype GYAddressBech32 = GYAddressBech32 GYAddress deriving newtype (Show, Eq, Ord, Printf.PrintfArg) @@ -513,64 +551,71 @@ addressFromBech32 :: GYAddressBech32 -> GYAddress addressFromBech32 = coerce instance Web.ToHttpApiData GYAddressBech32 where - toUrlPiece = coerce addressToText + toUrlPiece = coerce addressToText instance IsString GYAddressBech32 where - fromString = fromRight (error "invalid address") . Web.parseUrlPiece . Text.pack + fromString = fromRight (error "invalid address") . Web.parseUrlPiece . Text.pack --- | --- --- >>> Web.parseUrlPiece @GYAddressBech32 "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" --- Right (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") --- +{- | + +>>> Web.parseUrlPiece @GYAddressBech32 "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" +Right (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") +-} instance Web.FromHttpApiData GYAddressBech32 where - parseUrlPiece t = case addressFromTextMaybe t of - Just addr -> Right $ coerce addr - Nothing -> Left $ "Not an address: " <> t + parseUrlPiece t = case addressFromTextMaybe t of + Just addr -> Right $ coerce addr + Nothing -> Left $ "Not an address: " <> t --- | --- --- >>> LBS8.putStrLn $ Aeson.encode $ addressToBech32 addr --- "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode $ addressToBech32 addr +"addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" +-} instance ToJSON GYAddressBech32 where - toJSON (GYAddressBech32 addr) = Aeson.toJSON $ addressToText addr + toJSON (GYAddressBech32 addr) = Aeson.toJSON $ addressToText addr --- | --- --- >>> Aeson.decode @GYAddressBech32 "\"addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5\"" --- Just (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") --- +{- | + +>>> Aeson.decode @GYAddressBech32 "\"addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5\"" +Just (unsafeAddressFromText "addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5") +-} instance FromJSON GYAddressBech32 where - parseJSON = Aeson.withText "GYAddressBech32" $ \t -> - case Api.deserialiseAddress Api.AsAddressAny t of - Just addr -> return $ GYAddressBech32 $ GYAddress addr - Nothing -> fail "cannot deserialise address" + parseJSON = Aeson.withText "GYAddressBech32" $ \t -> + case Api.deserialiseAddress Api.AsAddressAny t of + Just addr -> return $ GYAddressBech32 $ GYAddress addr + Nothing -> fail "cannot deserialise address" instance PQ.ToField GYAddressBech32 where - toField (GYAddressBech32 addr) = PQ.toField $ addressToText addr + toField (GYAddressBech32 addr) = PQ.toField $ addressToText addr instance PQ.FromField GYAddressBech32 where - fromField f bs = do - t <- PQ.fromField f bs - case Api.deserialiseAddress Api.AsAddressAny t of - Just addr -> return $ GYAddressBech32 $ GYAddress addr - Nothing -> PQ.returnError PQ.ConversionFailed f "address does not unserialise" - + fromField f bs = do + t <- PQ.fromField f bs + case Api.deserialiseAddress Api.AsAddressAny t of + Just addr -> return $ GYAddressBech32 $ GYAddress addr + Nothing -> PQ.returnError PQ.ConversionFailed f "address does not unserialise" ------------------------------------------------------------------------------- -- swagger schema ------------------------------------------------------------------------------- instance Swagger.ToSchema GYAddressBech32 where - declareNamedSchema _ = pure $ Swagger.named "GYAddressBech32" $ Swagger.paramSchemaToSchema (Proxy @GYAddressBech32) - & Swagger.description ?~ "An address, serialised as Bech32." - & Swagger.example ?~ toJSON ("addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" :: Text) + declareNamedSchema _ = + pure $ + Swagger.named "GYAddressBech32" $ + Swagger.paramSchemaToSchema (Proxy @GYAddressBech32) + & Swagger.description + ?~ "An address, serialised as Bech32." + & Swagger.example + ?~ toJSON ("addr_test1qrsuhwqdhz0zjgnf46unas27h93amfghddnff8lpc2n28rgmjv8f77ka0zshfgssqr5cnl64zdnde5f8q2xt923e7ctqu49mg5" :: Text) instance Swagger.ToParamSchema GYAddressBech32 where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "bech32" + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "bech32" ------------------------------------------------------------------------------- -- Stake Address @@ -588,32 +633,33 @@ stakeAddressFromApi = coerce stakeAddressToApi :: GYStakeAddress -> Api.StakeAddress stakeAddressToApi = coerce --- | Obtain `GYStakeAddress` from bech32 encoding of stake address. --- --- >>> stakeAddressFromTextMaybe "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" --- Just (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") --- >>> stakeAddressFromTextMaybe "e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- Nothing --- +{- | Obtain `GYStakeAddress` from bech32 encoding of stake address. + +>>> stakeAddressFromTextMaybe "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" +Just (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") +>>> stakeAddressFromTextMaybe "e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +Nothing +-} stakeAddressFromTextMaybe :: Text.Text -> Maybe GYStakeAddress stakeAddressFromTextMaybe = coerce (Api.deserialiseAddress Api.AsStakeAddress) -- | Like `stakeAddressFromTextMaybe` but errors on `Nothing` case. unsafeStakeAddressFromText :: Text.Text -> GYStakeAddress -unsafeStakeAddressFromText t = fromMaybe +unsafeStakeAddressFromText t = + fromMaybe (error $ "Not a stake address: " ++ show t) (stakeAddressFromTextMaybe t) --- | Serialises `GYStakeAddress` to it's bech32 representation. --- --- >>> stakeAddressToText stakeAddr --- "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" --- +{- | Serialises `GYStakeAddress` to it's bech32 representation. + +>>> stakeAddressToText stakeAddr +"stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" +-} stakeAddressToText :: GYStakeAddress -> Text.Text stakeAddressToText = Api.serialiseAddress . stakeAddressToApi - {-# DEPRECATED stakeAddressCredential "Use stakeAddressToCredential." #-} + -- | Get a stake credential from a stake address. This drops the network information. stakeAddressCredential :: GYStakeAddress -> GYStakeCredential stakeAddressCredential = stakeCredentialFromApi . Api.stakeAddressCredential . stakeAddressToApi @@ -622,155 +668,169 @@ stakeAddressCredential = stakeCredentialFromApi . Api.stakeAddressCredential . s stakeAddressToCredential :: GYStakeAddress -> GYStakeCredential stakeAddressToCredential = stakeAddressCredential --- | Get a stake address from a stake credential. This also requires network information. --- --- >>> stakeAddr == stakeAddressFromCredential GYTestnetPreprod (stakeAddressToCredential stakeAddr) --- True +{- | Get a stake address from a stake credential. This also requires network information. + +>>> stakeAddr == stakeAddressFromCredential GYTestnetPreprod (stakeAddressToCredential stakeAddr) +True +-} stakeAddressFromCredential :: GYNetworkId -> GYStakeCredential -> GYStakeAddress stakeAddressFromCredential (networkIdToApi -> netId') (stakeCredentialToApi -> stakeCred') = Api.makeStakeAddress netId' stakeCred' & stakeAddressFromApi type GYStakeKeyHashString = String --- | --- --- >>> stakeKeyFromAddress addr --- Just "1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616" --- +{- | + +>>> stakeKeyFromAddress addr +Just "1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f616" +-} stakeKeyFromAddress :: GYAddress -> Maybe GYStakeKeyHashString stakeKeyFromAddress addr = addressToStakeCredential addr >>= Just . Text.unpack . stakeCredentialToHexText instance Show GYStakeAddress where - showsPrec d rewAddr = showParen (d > 10) $ - showString "unsafeStakeAddressFromText " . - showsPrec 11 (stakeAddressToText rewAddr) + showsPrec d rewAddr = + showParen (d > 10) $ + showString "unsafeStakeAddressFromText " + . showsPrec 11 (stakeAddressToText rewAddr) instance Hashable GYStakeAddress where - hashWithSalt salt = hashWithSalt salt . Api.serialiseToRawBytes . stakeAddressToApi + hashWithSalt salt = hashWithSalt salt . Api.serialiseToRawBytes . stakeAddressToApi --- | In JSON context, stake addresses are represented in hex. --- --- >>> Aeson.decode @GYStakeAddress "\"e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d\"" --- Just (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") --- +{- | In JSON context, stake addresses are represented in hex. + +>>> Aeson.decode @GYStakeAddress "\"e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d\"" +Just (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") +-} instance Aeson.FromJSON GYStakeAddress where - parseJSON = Aeson.withText "GYStakeAddress" $ \t -> - case Web.parseUrlPiece t of - Left err -> fail $ Text.unpack err - Right addr -> return addr + parseJSON = Aeson.withText "GYStakeAddress" $ \t -> + case Web.parseUrlPiece t of + Left err -> fail $ Text.unpack err + Right addr -> return addr --- | --- --- >>> LBS8.putStrLn $ Aeson.encode stakeAddr --- "e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode stakeAddr +"e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +-} instance Aeson.ToJSON GYStakeAddress where - toJSON = Aeson.String . Web.toUrlPiece + toJSON = Aeson.String . Web.toUrlPiece ------------------------------------------------------------------------------- -- http-api-data ------------------------------------------------------------------------------- --- | In an HTTP context, stake addresses are represented in hex. --- --- >>> Web.toUrlPiece stakeAddr --- "e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +{- | In an HTTP context, stake addresses are represented in hex. + +>>> Web.toUrlPiece stakeAddr +"e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +-} instance Web.ToHttpApiData GYStakeAddress where - toUrlPiece = TE.decodeLatin1 . Api.serialiseToRawBytesHex . stakeAddressToApi + toUrlPiece = TE.decodeLatin1 . Api.serialiseToRawBytesHex . stakeAddressToApi --- | --- --- >>> Web.parseUrlPiece @GYStakeAddress "e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- Right (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") --- --- >>> Web.parseUrlPiece @GYStakeAddress "00" --- Left "Not a stake address: 00; Reason: RawBytesHexErrorRawBytesDecodeFail \"00\" StakeAddress (SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise StakeAddress\"})" --- +{- | + +>>> Web.parseUrlPiece @GYStakeAddress "e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +Right (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") + +>>> Web.parseUrlPiece @GYStakeAddress "00" +Left "Not a stake address: 00; Reason: RawBytesHexErrorRawBytesDecodeFail \"00\" StakeAddress (SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise StakeAddress\"})" +-} instance Web.FromHttpApiData GYStakeAddress where - parseUrlPiece t = case Api.deserialiseFromRawBytesHex Api.AsStakeAddress (TE.encodeUtf8 t) of - Right addr -> Right $ stakeAddressFromApi addr - Left x -> Left $ "Not a stake address: " <> t <> "; Reason: " <> Text.pack (show x) + parseUrlPiece t = case Api.deserialiseFromRawBytesHex Api.AsStakeAddress (TE.encodeUtf8 t) of + Right addr -> Right $ stakeAddressFromApi addr + Left x -> Left $ "Not a stake address: " <> t <> "; Reason: " <> Text.pack (show x) ------------------------------------------------------------------------------- -- CSV ------------------------------------------------------------------------------- --- | --- --- >>> Csv.toField stakeAddr --- "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" --- +{- | + +>>> Csv.toField stakeAddr +"stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" +-} instance Csv.ToField GYStakeAddress where - toField = encodeUtf8 . stakeAddressToText + toField = encodeUtf8 . stakeAddressToText --- | --- --- >>> Csv.runParser $ Csv.parseField @GYStakeAddress "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" --- Right (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") --- --- >>> Csv.runParser $ Csv.parseField @GYStakeAddress "not a stake address" --- Left "Not a stake address: not a stake address" --- +{- | + +>>> Csv.runParser $ Csv.parseField @GYStakeAddress "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" +Right (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") + +>>> Csv.runParser $ Csv.parseField @GYStakeAddress "not a stake address" +Left "Not a stake address: not a stake address" +-} instance Csv.FromField GYStakeAddress where - parseField f = - let t = decodeUtf8Lenient f - in maybe (fail $ "Not a stake address: " <> Text.unpack t) return $ stakeAddressFromTextMaybe t + parseField f = + let t = decodeUtf8Lenient f + in maybe (fail $ "Not a stake address: " <> Text.unpack t) return $ stakeAddressFromTextMaybe t --- | --- --- >>> Csv.encodeWith (Csv.defaultEncodeOptions {Csv.encUseCrLf = False}) [stakeAddr] --- "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3\n" --- +{- | + +>>> Csv.encodeWith (Csv.defaultEncodeOptions {Csv.encUseCrLf = False}) [stakeAddr] +"stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3\n" +-} instance Csv.ToRecord GYStakeAddress where - toRecord = Vector.singleton . Csv.toField + toRecord = Vector.singleton . Csv.toField --- | --- --- >>> Csv.decode @GYStakeAddress Csv.NoHeader "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3\n" --- Right [unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3"] --- --- >>> Csv.decode @GYStakeAddress Csv.NoHeader "not a stake address\n" --- Left "parse error (Failed reading: conversion error: Not a stake address: not a stake address) at \"\\n\"" --- --- >>> Csv.decode @GYStakeAddress Csv.NoHeader "not, a, stake address\n" --- Left "parse error (Failed reading: conversion error: expected exactly one field, but got: [\"not\",\" a\",\" stake address\"]) at \"\\n\"" --- +{- | + +>>> Csv.decode @GYStakeAddress Csv.NoHeader "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3\n" +Right [unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3"] + +>>> Csv.decode @GYStakeAddress Csv.NoHeader "not a stake address\n" +Left "parse error (Failed reading: conversion error: Not a stake address: not a stake address) at \"\\n\"" + +>>> Csv.decode @GYStakeAddress Csv.NoHeader "not, a, stake address\n" +Left "parse error (Failed reading: conversion error: expected exactly one field, but got: [\"not\",\" a\",\" stake address\"]) at \"\\n\"" +-} instance Csv.FromRecord GYStakeAddress where - parseRecord v = case Vector.toList v of - [bs] -> Csv.parseField bs - _ -> fail $ printf "expected exactly one field, but got: %s" $ show v + parseRecord v = case Vector.toList v of + [bs] -> Csv.parseField bs + _ -> fail $ printf "expected exactly one field, but got: %s" $ show v ------------------------------------------------------------------------------- -- swagger schema ------------------------------------------------------------------------------- instance Swagger.ToParamSchema GYStakeAddress where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "cbor hex" - & Swagger.maxLength ?~ 58 - & Swagger.minLength ?~ 58 + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "cbor hex" + & Swagger.maxLength + ?~ 58 + & Swagger.minLength + ?~ 58 instance Swagger.ToSchema GYStakeAddress where - declareNamedSchema _ = pure $ Swagger.named "GYStakeAddress" $ Swagger.paramSchemaToSchema (Proxy @GYStakeAddress) - & Swagger.description ?~ "A stake address, serialised as CBOR." - & Swagger.example ?~ toJSON ("e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" :: Text) + declareNamedSchema _ = + pure $ + Swagger.named "GYStakeAddress" $ + Swagger.paramSchemaToSchema (Proxy @GYStakeAddress) + & Swagger.description + ?~ "A stake address, serialised as CBOR." + & Swagger.example + ?~ toJSON ("e07a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" :: Text) ------------------------------------------------------------------------------- -- Text.Printf ------------------------------------------------------------------------------- --- | This instance is using for logging --- --- >>> Printf.printf "stake addr = %s" stakeAddr --- stake addr = stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3 +{- | This instance is using for logging + +>>> Printf.printf "stake addr = %s" stakeAddr +stake addr = stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3 +-} instance Printf.PrintfArg GYStakeAddress where - formatArg stakeAddr = Printf.formatArg (stakeAddressToText stakeAddr) + formatArg stakeAddr = Printf.formatArg (stakeAddressToText stakeAddr) --- | 'GYStakeAddressBech32' which uses "bech32" format --- --- >>> Web.toUrlPiece $ stakeAddressToBech32 stakeAddr --- "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" --- +{- | 'GYStakeAddressBech32' which uses "bech32" format + +>>> Web.toUrlPiece $ stakeAddressToBech32 stakeAddr +"stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" +-} newtype GYStakeAddressBech32 = GYStakeAddressBech32 GYStakeAddress deriving newtype (Show, Eq, Ord, Printf.PrintfArg) @@ -781,61 +841,68 @@ stakeAddressFromBech32 :: GYStakeAddressBech32 -> GYStakeAddress stakeAddressFromBech32 = coerce instance Web.ToHttpApiData GYStakeAddressBech32 where - toUrlPiece = coerce stakeAddressToText + toUrlPiece = coerce stakeAddressToText instance IsString GYStakeAddressBech32 where - fromString = fromRight (error "invalid stake address") . Web.parseUrlPiece . Text.pack + fromString = fromRight (error "invalid stake address") . Web.parseUrlPiece . Text.pack --- | --- --- >>> Web.parseUrlPiece @GYStakeAddressBech32 "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" --- Right (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") --- +{- | + +>>> Web.parseUrlPiece @GYStakeAddressBech32 "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" +Right (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") +-} instance Web.FromHttpApiData GYStakeAddressBech32 where - parseUrlPiece t = case stakeAddressFromTextMaybe t of - Just stakeAddr -> Right $ coerce stakeAddr - Nothing -> Left $ "Not a stake address: " <> t + parseUrlPiece t = case stakeAddressFromTextMaybe t of + Just stakeAddr -> Right $ coerce stakeAddr + Nothing -> Left $ "Not a stake address: " <> t --- | --- --- >>> LBS8.putStrLn $ Aeson.encode $ stakeAddressToBech32 stakeAddr --- "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode $ stakeAddressToBech32 stakeAddr +"stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" +-} instance ToJSON GYStakeAddressBech32 where - toJSON (GYStakeAddressBech32 stakeAddr) = Aeson.toJSON $ stakeAddressToText stakeAddr + toJSON (GYStakeAddressBech32 stakeAddr) = Aeson.toJSON $ stakeAddressToText stakeAddr --- | --- --- >>> Aeson.decode @GYStakeAddressBech32 "\"stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3\"" --- Just (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") --- +{- | + +>>> Aeson.decode @GYStakeAddressBech32 "\"stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3\"" +Just (unsafeStakeAddressFromText "stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3") +-} instance FromJSON GYStakeAddressBech32 where - parseJSON = Aeson.withText "GYStakeAddressBech32" $ \t -> - case stakeAddressFromTextMaybe t of - Just stakeAddr -> return $ GYStakeAddressBech32 stakeAddr - Nothing -> fail "cannot deserialise stake address" + parseJSON = Aeson.withText "GYStakeAddressBech32" $ \t -> + case stakeAddressFromTextMaybe t of + Just stakeAddr -> return $ GYStakeAddressBech32 stakeAddr + Nothing -> fail "cannot deserialise stake address" instance PQ.ToField GYStakeAddressBech32 where - toField (GYStakeAddressBech32 stakeAddr) = PQ.toField $ stakeAddressToText stakeAddr + toField (GYStakeAddressBech32 stakeAddr) = PQ.toField $ stakeAddressToText stakeAddr instance PQ.FromField GYStakeAddressBech32 where - fromField f bs = do - t <- PQ.fromField f bs - case stakeAddressFromTextMaybe t of - Just stakeAddr -> return $ GYStakeAddressBech32 stakeAddr - Nothing -> PQ.returnError PQ.ConversionFailed f "stake address does not unserialise" - + fromField f bs = do + t <- PQ.fromField f bs + case stakeAddressFromTextMaybe t of + Just stakeAddr -> return $ GYStakeAddressBech32 stakeAddr + Nothing -> PQ.returnError PQ.ConversionFailed f "stake address does not unserialise" ------------------------------------------------------------------------------- -- swagger schema ------------------------------------------------------------------------------- instance Swagger.ToSchema GYStakeAddressBech32 where - declareNamedSchema _ = pure $ Swagger.named "GYStakeAddressBech32" $ Swagger.paramSchemaToSchema (Proxy @GYStakeAddressBech32) - & Swagger.description ?~ "A stake address, serialised as Bech32." - & Swagger.example ?~ toJSON ("stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" :: Text) + declareNamedSchema _ = + pure $ + Swagger.named "GYStakeAddressBech32" $ + Swagger.paramSchemaToSchema (Proxy @GYStakeAddressBech32) + & Swagger.description + ?~ "A stake address, serialised as Bech32." + & Swagger.example + ?~ toJSON ("stake_test1upa805fqh85x4hw88zxmhvdaydgyjzmazs9tydqrscerxnghfq4t3" :: Text) instance Swagger.ToParamSchema GYStakeAddressBech32 where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "bech32" + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "bech32" diff --git a/src/GeniusYield/Types/Certificate.hs b/src/GeniusYield/Types/Certificate.hs index 3a148dc1..ad53cd5e 100644 --- a/src/GeniusYield/Types/Certificate.hs +++ b/src/GeniusYield/Types/Certificate.hs @@ -1,10 +1,9 @@ -{-| +{- | Module : GeniusYield.Types.Certificate Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Certificate ( GYCertificatePreBuild (..), @@ -15,31 +14,35 @@ module GeniusYield.Types.Certificate ( certificateToStakeCredential, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.ReexposeLedger as Ledger -import qualified Cardano.Ledger.Api as Ledger -import Control.Lens ((^.)) -import GeniusYield.Types.Credential (GYStakeCredential, - stakeCredentialFromLedger, - stakeCredentialToApi) -import GeniusYield.Types.Delegatee (GYDelegatee, - delegateeFromLedger, - delegateeToLedger) -import GeniusYield.Types.Era -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) -import GHC.Natural (Natural) +import Cardano.Api qualified as Api +import Cardano.Api.ReexposeLedger qualified as Ledger +import Cardano.Ledger.Api qualified as Ledger +import Control.Lens ((^.)) +import GHC.Natural (Natural) +import GeniusYield.Types.Credential ( + GYStakeCredential, + stakeCredentialFromLedger, + stakeCredentialToApi, + ) +import GeniusYield.Types.Delegatee ( + GYDelegatee, + delegateeFromLedger, + delegateeToLedger, + ) +import GeniusYield.Types.Era +import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) -- | Certificate state before building the transaction. -data GYCertificatePreBuild = - GYStakeAddressRegistrationCertificatePB !GYStakeCredential +data GYCertificatePreBuild + = GYStakeAddressRegistrationCertificatePB !GYStakeCredential | GYStakeAddressDeregistrationCertificatePB !GYStakeCredential | GYStakeAddressDelegationCertificatePB !GYStakeCredential !GYDelegatee | GYStakeAddressRegistrationDelegationCertificatePB !GYStakeCredential !GYDelegatee deriving stock (Eq, Ord, Show) -- | Certificate state after populating missing entries from `GYCertificatePreBuild`. -data GYCertificate = - GYStakeAddressRegistrationCertificate !Natural !GYStakeCredential +data GYCertificate + = GYStakeAddressRegistrationCertificate !Natural !GYStakeCredential | GYStakeAddressDeregistrationCertificate !Natural !GYStakeCredential | GYStakeAddressDelegationCertificate !GYStakeCredential !GYDelegatee | GYStakeAddressRegistrationDelegationCertificate !Natural !GYStakeCredential !GYDelegatee @@ -52,19 +55,23 @@ finaliseCert pp = \case GYStakeAddressDeregistrationCertificatePB sc -> GYStakeAddressDeregistrationCertificate ppDep' sc GYStakeAddressDelegationCertificatePB sc del -> GYStakeAddressDelegationCertificate sc del GYStakeAddressRegistrationDelegationCertificatePB sc del -> GYStakeAddressRegistrationDelegationCertificate ppDep' sc del - where Ledger.Coin ppDep = pp ^. Ledger.ppKeyDepositL ppDep' :: Natural = fromIntegral ppDep certificateToApi :: GYCertificate -> Api.Certificate ApiEra certificateToApi = \case - GYStakeAddressRegistrationCertificate dep sc -> Api.makeStakeAddressRegistrationCertificate - . Api.StakeAddrRegistrationConway Api.ConwayEraOnwardsConway (fromIntegral dep) $ f sc - GYStakeAddressDeregistrationCertificate ref sc -> Api.makeStakeAddressUnregistrationCertificate - . Api.StakeAddrRegistrationConway Api.ConwayEraOnwardsConway (fromIntegral ref) $ f sc - GYStakeAddressDelegationCertificate sc del -> Api.makeStakeAddressDelegationCertificate - $ Api.StakeDelegationRequirementsConwayOnwards Api.ConwayEraOnwardsConway (f sc) (g del) + GYStakeAddressRegistrationCertificate dep sc -> + Api.makeStakeAddressRegistrationCertificate + . Api.StakeAddrRegistrationConway Api.ConwayEraOnwardsConway (fromIntegral dep) + $ f sc + GYStakeAddressDeregistrationCertificate ref sc -> + Api.makeStakeAddressUnregistrationCertificate + . Api.StakeAddrRegistrationConway Api.ConwayEraOnwardsConway (fromIntegral ref) + $ f sc + GYStakeAddressDelegationCertificate sc del -> + Api.makeStakeAddressDelegationCertificate $ + Api.StakeDelegationRequirementsConwayOnwards Api.ConwayEraOnwardsConway (f sc) (g del) GYStakeAddressRegistrationDelegationCertificate dep sc del -> Api.makeStakeAddressAndDRepDelegationCertificate Api.ConwayEraOnwardsConway (f sc) (g del) (fromIntegral dep) where f = stakeCredentialToApi diff --git a/src/GeniusYield/Types/Credential.hs b/src/GeniusYield/Types/Credential.hs index 64cc2ebb..bbf42a2d 100644 --- a/src/GeniusYield/Types/Credential.hs +++ b/src/GeniusYield/Types/Credential.hs @@ -1,74 +1,79 @@ -{-| +{- | Module : GeniusYield.Types.Credential Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Credential ( - -- * Payment credential. - GYPaymentCredential (..) - , paymentCredentialToApi - , paymentCredentialFromApi - , paymentCredentialToLedger - , paymentCredentialFromLedger - , paymentCredentialToPlutus - , paymentCredentialToHexText - , paymentCredentialToBech32 - -- * Stake credential. - , GYStakeCredential (..) - , stakeCredentialToApi - , stakeCredentialFromApi - , stakeCredentialToLedger - , stakeCredentialFromLedger - , stakeCredentialToPlutus - , stakeCredentialToHexText - ) where - - -import qualified Cardano.Api as Api -import qualified Cardano.Api.Ledger as Ledger -import qualified Cardano.Api.Shelley as Api -import Data.Hashable (Hashable (..)) -import Data.Text (Text) -import GeniusYield.Imports ((>>>)) -import GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash, - paymentKeyHashFromApi, - paymentKeyHashFromLedger, - paymentKeyHashToApi, - paymentKeyHashToLedger, - paymentKeyHashToPlutus) -import GeniusYield.Types.PubKeyHash (AsPubKeyHash (fromPubKeyHash, toPubKeyHash)) -import GeniusYield.Types.Script (GYScriptHash, - GYStakeValidatorHash, - scriptHashFromApi, - scriptHashFromLedger, - scriptHashToApi, - scriptHashToLedger, - scriptHashToPlutus, - stakeValidatorHashFromApi, - stakeValidatorHashToApi, - stakeValidatorHashToPlutus) -import GeniusYield.Types.StakeKeyHash (GYStakeKeyHash, - stakeKeyHashFromApi, - stakeKeyHashToApi) -import GeniusYield.Utils (serialiseToBech32WithPrefix) -import qualified PlutusLedgerApi.V1 as Plutus (Credential (..)) -import qualified Text.Printf as Printf + -- * Payment credential. + GYPaymentCredential (..), + paymentCredentialToApi, + paymentCredentialFromApi, + paymentCredentialToLedger, + paymentCredentialFromLedger, + paymentCredentialToPlutus, + paymentCredentialToHexText, + paymentCredentialToBech32, + + -- * Stake credential. + GYStakeCredential (..), + stakeCredentialToApi, + stakeCredentialFromApi, + stakeCredentialToLedger, + stakeCredentialFromLedger, + stakeCredentialToPlutus, + stakeCredentialToHexText, +) where + +import Cardano.Api qualified as Api +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api +import Data.Hashable (Hashable (..)) +import Data.Text (Text) +import GeniusYield.Imports ((>>>)) +import GeniusYield.Types.PaymentKeyHash ( + GYPaymentKeyHash, + paymentKeyHashFromApi, + paymentKeyHashFromLedger, + paymentKeyHashToApi, + paymentKeyHashToLedger, + paymentKeyHashToPlutus, + ) +import GeniusYield.Types.PubKeyHash (AsPubKeyHash (fromPubKeyHash, toPubKeyHash)) +import GeniusYield.Types.Script ( + GYScriptHash, + GYStakeValidatorHash, + scriptHashFromApi, + scriptHashFromLedger, + scriptHashToApi, + scriptHashToLedger, + scriptHashToPlutus, + stakeValidatorHashFromApi, + stakeValidatorHashToApi, + stakeValidatorHashToPlutus, + ) +import GeniusYield.Types.StakeKeyHash ( + GYStakeKeyHash, + stakeKeyHashFromApi, + stakeKeyHashToApi, + ) +import GeniusYield.Utils (serialiseToBech32WithPrefix) +import PlutusLedgerApi.V1 qualified as Plutus (Credential (..)) +import Text.Printf qualified as Printf -- | Payment credential. data GYPaymentCredential - = GYPaymentCredentialByKey !GYPaymentKeyHash - | GYPaymentCredentialByScript !GYScriptHash - deriving (Show, Eq, Ord) + = GYPaymentCredentialByKey !GYPaymentKeyHash + | GYPaymentCredentialByScript !GYScriptHash + deriving (Show, Eq, Ord) instance Printf.PrintfArg GYPaymentCredential where formatArg (GYPaymentCredentialByKey pkh) = Printf.formatArg $ "Payment key credential: " <> Api.serialiseToRawBytesHexText (paymentKeyHashToApi pkh) formatArg (GYPaymentCredentialByScript sh) = Printf.formatArg $ "Payment script credential: " <> Api.serialiseToRawBytesHexText (scriptHashToApi sh) instance Hashable GYPaymentCredential where - hashWithSalt salt cred = hashWithSalt salt $ paymentCredentialToHexText cred + hashWithSalt salt cred = hashWithSalt salt $ paymentCredentialToHexText cred -- | Convert @GY@ type to corresponding type in @cardano-node@ library. paymentCredentialToApi :: GYPaymentCredential -> Api.PaymentCredential @@ -110,9 +115,9 @@ paymentCredentialToBech32 (GYPaymentCredentialByScript sh) = serialiseToBech32Wi -- | Stake credential. data GYStakeCredential - = GYStakeCredentialByKey !GYStakeKeyHash - | GYStakeCredentialByScript !GYStakeValidatorHash - deriving (Show, Eq, Ord) + = GYStakeCredentialByKey !GYStakeKeyHash + | GYStakeCredentialByScript !GYStakeValidatorHash + deriving (Show, Eq, Ord) instance Printf.PrintfArg GYStakeCredential where formatArg (GYStakeCredentialByKey skh) = Printf.formatArg $ "Stake key credential: " <> Api.serialiseToRawBytesHexText (stakeKeyHashToApi skh) diff --git a/src/GeniusYield/Types/DRep.hs b/src/GeniusYield/Types/DRep.hs index 3207c583..ce4ca3ce 100644 --- a/src/GeniusYield/Types/DRep.hs +++ b/src/GeniusYield/Types/DRep.hs @@ -1,10 +1,9 @@ -{-| +{- | Module : GeniusYield.Types.DRep Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.DRep ( GYDRep, @@ -12,13 +11,17 @@ module GeniusYield.Types.DRep ( drepFromLedger, ) where -import qualified Cardano.Api.Ledger as Ledger -import GeniusYield.Types.PubKeyHash (GYPubKeyHash, - pubKeyHashFromLedger, - pubKeyHashToLedger) -import GeniusYield.Types.Script.ScriptHash (GYScriptHash, - scriptHashFromLedger, - scriptHashToLedger) +import Cardano.Api.Ledger qualified as Ledger +import GeniusYield.Types.PubKeyHash ( + GYPubKeyHash, + pubKeyHashFromLedger, + pubKeyHashToLedger, + ) +import GeniusYield.Types.Script.ScriptHash ( + GYScriptHash, + scriptHashFromLedger, + scriptHashToLedger, + ) data GYDRep = GYDRepKeyHash !GYPubKeyHash @@ -37,7 +40,7 @@ drepToLedger drep = case drep of drepFromLedger :: Ledger.DRep Ledger.StandardCrypto -> GYDRep drepFromLedger drep = case drep of Ledger.DRepCredential s -> case s of - Ledger.KeyHashObj kh -> GYDRepKeyHash $ pubKeyHashFromLedger kh + Ledger.KeyHashObj kh -> GYDRepKeyHash $ pubKeyHashFromLedger kh Ledger.ScriptHashObj sh -> GYDRepScriptHash $ scriptHashFromLedger sh Ledger.DRepAlwaysAbstain -> GYDRepAlwaysAbstain Ledger.DRepAlwaysNoConfidence -> GYDRepAlwaysNoConfidence diff --git a/src/GeniusYield/Types/Datum.hs b/src/GeniusYield/Types/Datum.hs index 8c054ef6..a88d16d4 100644 --- a/src/GeniusYield/Types/Datum.hs +++ b/src/GeniusYield/Types/Datum.hs @@ -1,81 +1,85 @@ -{-| +{- | Module : GeniusYield.Types.Datum Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Datum ( - -- * Docspec setup - -- $setup - - -- * Datum - GYDatum, - datumToApi', - datumFromApi', - datumToPlutus, - datumToPlutus', - datumFromPlutus, - datumFromPlutus', - datumFromPlutusData, - unitDatum, - hashDatum, - -- * Datum hash - GYDatumHash, - datumHashFromHex, - datumHashFromHexE, - datumHashFromPlutus, - unsafeDatumHashFromPlutus, - datumHashToPlutus, - datumHashFromApi, - datumHashToApi, + -- * Docspec setup + -- $setup + + -- * Datum + GYDatum, + datumToApi', + datumFromApi', + datumToPlutus, + datumToPlutus', + datumFromPlutus, + datumFromPlutus', + datumFromPlutusData, + unitDatum, + hashDatum, + + -- * Datum hash + GYDatumHash, + datumHashFromHex, + datumHashFromHexE, + datumHashFromPlutus, + unsafeDatumHashFromPlutus, + datumHashToPlutus, + datumHashFromApi, + datumHashToApi, ) where -import qualified Cardano.Api as Api -import Control.Monad ((>=>)) -import qualified Data.Aeson as Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BS8 -import Data.Either.Combinators (mapLeft) -import qualified Data.Text as Txt -import qualified Database.PostgreSQL.Simple as PQ -import qualified Database.PostgreSQL.Simple.FromField as PQ (FromField (..), - returnError) -import qualified Database.PostgreSQL.Simple.ToField as PQ -import qualified PlutusLedgerApi.V1.Scripts as Plutus -import qualified PlutusTx -import qualified PlutusTx.Builtins as PlutusTx - -import qualified Cardano.Api.Shelley as Api -import GeniusYield.Imports -import GeniusYield.Types.Ledger -import qualified Web.HttpApiData as Web - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Char8 as BS8 --- >>> import qualified Data.ByteString.Lazy as BSL --- >>> import qualified Web.HttpApiData as Web --- >>> - --- | Datum --- --- In the GY system we always include datums in transactions --- so this simple type is sufficient. --- +import Cardano.Api qualified as Api +import Control.Monad ((>=>)) +import Data.Aeson qualified as Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Base16 qualified as Base16 +import Data.ByteString.Char8 qualified as BS8 +import Data.Either.Combinators (mapLeft) +import Data.Text qualified as Txt +import Database.PostgreSQL.Simple qualified as PQ +import Database.PostgreSQL.Simple.FromField qualified as PQ ( + FromField (..), + returnError, + ) +import Database.PostgreSQL.Simple.ToField qualified as PQ +import PlutusLedgerApi.V1.Scripts qualified as Plutus +import PlutusTx qualified +import PlutusTx.Builtins qualified as PlutusTx + +import Cardano.Api.Shelley qualified as Api +import GeniusYield.Imports +import GeniusYield.Types.Ledger +import Web.HttpApiData qualified as Web + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Char8 as BS8 +>>> import qualified Data.ByteString.Lazy as BSL +>>> import qualified Web.HttpApiData as Web +>>> +-} + +{- | Datum + +In the GY system we always include datums in transactions +so this simple type is sufficient. +-} newtype GYDatum = GYDatum PlutusTx.BuiltinData - deriving stock (Eq, Ord, Show) - deriving newtype (PlutusTx.ToData, PlutusTx.FromData) + deriving stock (Eq, Ord, Show) + deriving newtype (PlutusTx.ToData, PlutusTx.FromData) --- | Convert a 'GYDatum' to 'Api.HashableScriptData' from Cardano Api. --- --- __NOTE:__ This function is to be used only when generating for new outputs in a transaction as doing `datumFromApi'` followed by `datumToApi'` does not guarantee same low level CBOR representation of the high level data type. +{- | Convert a 'GYDatum' to 'Api.HashableScriptData' from Cardano Api. + +__NOTE:__ This function is to be used only when generating for new outputs in a transaction as doing `datumFromApi'` followed by `datumToApi'` does not guarantee same low level CBOR representation of the high level data type. +-} datumToApi' :: GYDatum -> Api.HashableScriptData -datumToApi' = datumToPlutus' >>> PlutusTx.builtinDataToData >>> Api.fromPlutusData >>> Api.unsafeHashableScriptData -- @unsafeHashableScriptData@ is fine here as there is no original datum bytes here, i.e. to say, this is a new datum which we are serialising and since we are serialising, we govern it. +datumToApi' = datumToPlutus' >>> PlutusTx.builtinDataToData >>> Api.fromPlutusData >>> Api.unsafeHashableScriptData -- @unsafeHashableScriptData@ is fine here as there is no original datum bytes here, i.e. to say, this is a new datum which we are serialising and since we are serialising, we govern it. -- | Get a 'GYDatum' from a Cardano Api 'Api.ScriptData' datumFromApi' :: Api.HashableScriptData -> GYDatum @@ -98,12 +102,13 @@ datumFromPlutus' :: PlutusTx.BuiltinData -> GYDatum datumFromPlutus' = GYDatum -- | Get a 'GYDatum' from any Plutus 'Plutus.ToData' type. -datumFromPlutusData :: PlutusTx.ToData a => a -> GYDatum +datumFromPlutusData :: (PlutusTx.ToData a) => a -> GYDatum datumFromPlutusData = GYDatum . PlutusTx.toBuiltinData --- | Unit datum --- --- @'datumFromPlutusData' ()@. +{- | Unit datum + +@'datumFromPlutusData' ()@. +-} unitDatum :: GYDatum unitDatum = datumFromPlutusData () @@ -115,69 +120,73 @@ hashDatum = datumHashFromApi . Api.hashScriptDataBytes . datumToApi' -- aeson ------------------------------------------------------------------------------- --- | Datums use cardano-api's detailed schema for JSON representation. --- --- >>> Aeson.decode @GYDatum "{\"constructor\":0,\"fields\":[{\"int\":42},{\"list\":[{\"bytes\":\"\"}]}]}" --- Just (GYDatum Constr 0 [I 42,List [B ""]]) --- +{- | Datums use cardano-api's detailed schema for JSON representation. + +>>> Aeson.decode @GYDatum "{\"constructor\":0,\"fields\":[{\"int\":42},{\"list\":[{\"bytes\":\"\"}]}]}" +Just (GYDatum Constr 0 [I 42,List [B ""]]) +-} instance Aeson.FromJSON GYDatum where - parseJSON = either (fail . show) (pure . datumFromApi') . Api.scriptDataFromJsonDetailedSchema + parseJSON = either (fail . show) (pure . datumFromApi') . Api.scriptDataFromJsonDetailedSchema --- | --- --- >>> BSL.putStr . Aeson.encode . datumFromPlutus' . PlutusTx.dataToBuiltinData $ PlutusTx.Constr 0 [ PlutusTx.I 42, PlutusTx.List [ PlutusTx.B "" ] ] --- {"constructor":0,"fields":[{"int":42},{"list":[{"bytes":""}]}]} --- +{- | + +>>> BSL.putStr . Aeson.encode . datumFromPlutus' . PlutusTx.dataToBuiltinData $ PlutusTx.Constr 0 [ PlutusTx.I 42, PlutusTx.List [ PlutusTx.B "" ] ] +{"constructor":0,"fields":[{"int":42},{"list":[{"bytes":""}]}]} +-} instance Aeson.ToJSON GYDatum where - toJSON = Api.scriptDataToJsonDetailedSchema . datumToApi' + toJSON = Api.scriptDataToJsonDetailedSchema . datumToApi' ------------------------------------------------------------------------------- -- DatumHash ------------------------------------------------------------------------------- newtype GYDatumHash = GYDatumHash (Api.Hash Api.ScriptData) - deriving stock (Show) - deriving newtype (Eq, Ord, ToJSON, FromJSON) + deriving stock (Show) + deriving newtype (Eq, Ord, ToJSON, FromJSON) -- >>> Web.toUrlPiece (GYDatumHash "0103c27d58a7b32241bb7f03045fae8edc01dd2f2a70a349addc17f6536fde76") -- "0103c27d58a7b32241bb7f03045fae8edc01dd2f2a70a349addc17f6536fde76" -- instance Web.ToHttpApiData GYDatumHash where - toUrlPiece = Api.serialiseToRawBytesHexText . datumHashToApi + toUrlPiece = Api.serialiseToRawBytesHexText . datumHashToApi instance IsString GYDatumHash where - fromString = unsafeDatumHashFromPlutus . fromString + fromString = unsafeDatumHashFromPlutus . fromString instance PQ.FromField GYDatumHash where - fromField f bs' = do - PQ.Binary bs <- PQ.fromField f bs' - case Api.deserialiseFromRawBytes (Api.AsHash Api.AsScriptData) bs of - Right dh -> return (datumHashFromApi dh) - Left e -> PQ.returnError PQ.ConversionFailed f ("datum hash does not unserialise: " <> show e) + fromField f bs' = do + PQ.Binary bs <- PQ.fromField f bs' + case Api.deserialiseFromRawBytes (Api.AsHash Api.AsScriptData) bs of + Right dh -> return (datumHashFromApi dh) + Left e -> PQ.returnError PQ.ConversionFailed f ("datum hash does not unserialise: " <> show e) instance PQ.ToField GYDatumHash where - toField (GYDatumHash dh) = PQ.toField (PQ.Binary (Api.serialiseToRawBytes dh)) + toField (GYDatumHash dh) = PQ.toField (PQ.Binary (Api.serialiseToRawBytes dh)) datumHashFromHex :: String -> Maybe GYDatumHash datumHashFromHex = rightToMaybe . datumHashFromHexE datumHashFromBS :: ByteString -> Either String GYDatumHash -datumHashFromBS = fmap datumHashFromApi +datumHashFromBS = + fmap datumHashFromApi . mapLeft (\e -> "RawBytes GYDatumHash decode fail: " <> show e) . Api.deserialiseFromRawBytes (Api.proxyToAsType @(Api.Hash Api.ScriptData) Proxy) datumHashFromHexE :: String -> Either String GYDatumHash -datumHashFromHexE = Base16.decode . BS8.pack +datumHashFromHexE = + Base16.decode . BS8.pack >=> datumHashFromBS datumHashFromPlutus :: Plutus.DatumHash -> Either PlutusToCardanoError GYDatumHash -datumHashFromPlutus (Plutus.DatumHash h) = first - (\t -> DeserialiseRawBytesError . Txt.pack $ "datumHashFromPlutus" ++ '.':t) - . datumHashFromBS $ PlutusTx.fromBuiltin h +datumHashFromPlutus (Plutus.DatumHash h) = + first + (\t -> DeserialiseRawBytesError . Txt.pack $ "datumHashFromPlutus" ++ '.' : t) + . datumHashFromBS + $ PlutusTx.fromBuiltin h unsafeDatumHashFromPlutus :: Plutus.DatumHash -> GYDatumHash unsafeDatumHashFromPlutus = - either (error . ("unsafeDatumHashFromPlutus: " ++) . show) id . datumHashFromPlutus + either (error . ("unsafeDatumHashFromPlutus: " ++) . show) id . datumHashFromPlutus datumHashToPlutus :: GYDatumHash -> Plutus.DatumHash datumHashToPlutus h = Plutus.DatumHash (PlutusTx.toBuiltin (Api.serialiseToRawBytes (datumHashToApi h))) diff --git a/src/GeniusYield/Types/Delegatee.hs b/src/GeniusYield/Types/Delegatee.hs index 1bb6b7f6..d34f24de 100644 --- a/src/GeniusYield/Types/Delegatee.hs +++ b/src/GeniusYield/Types/Delegatee.hs @@ -1,10 +1,9 @@ -{-| +{- | Module : GeniusYield.Types.Delegatee Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Delegatee ( GYDelegatee (..), @@ -12,12 +11,12 @@ module GeniusYield.Types.Delegatee ( delegateeFromLedger, ) where -import qualified Cardano.Api.Ledger as Api -import qualified Cardano.Api.Ledger as Ledger -import qualified Cardano.Api.Shelley as Api.S -import GeniusYield.Types.DRep -import GeniusYield.Types.Era -import GeniusYield.Types.StakePoolId +import Cardano.Api.Ledger qualified as Api +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api.S +import GeniusYield.Types.DRep +import GeniusYield.Types.Era +import GeniusYield.Types.StakePoolId data GYDelegatee = GYDelegStake !GYStakePoolId @@ -27,12 +26,12 @@ data GYDelegatee delegateeToLedger :: GYDelegatee -> Ledger.Delegatee (Api.EraCrypto (Api.S.ShelleyLedgerEra ApiEra)) delegateeToLedger del = case del of - GYDelegStake sp -> Ledger.DelegStake $ stakePoolIdToLedger sp + GYDelegStake sp -> Ledger.DelegStake $ stakePoolIdToLedger sp GYDelegVote drep -> Ledger.DelegVote $ drepToLedger drep GYDelegStakeVote sp drep -> Ledger.DelegStakeVote (stakePoolIdToLedger sp) (drepToLedger drep) delegateeFromLedger :: Ledger.Delegatee (Api.EraCrypto (Api.S.ShelleyLedgerEra ApiEra)) -> GYDelegatee delegateeFromLedger del = case del of - Ledger.DelegStake sp -> GYDelegStake $ stakePoolIdFromLedger sp + Ledger.DelegStake sp -> GYDelegStake $ stakePoolIdFromLedger sp Ledger.DelegVote drep -> GYDelegVote $ drepFromLedger drep Ledger.DelegStakeVote sp drep -> GYDelegStakeVote (stakePoolIdFromLedger sp) (drepFromLedger drep) diff --git a/src/GeniusYield/Types/Era.hs b/src/GeniusYield/Types/Era.hs index 76466645..08c654c8 100644 --- a/src/GeniusYield/Types/Era.hs +++ b/src/GeniusYield/Types/Era.hs @@ -1,16 +1,15 @@ -{-| +{- | Module : GeniusYield.Types.Era Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Era ( - ApiEra, + ApiEra, ) where -import qualified Cardano.Api.Shelley as Api.S +import Cardano.Api.Shelley qualified as Api.S -- TODO: Make this module internal. type ApiEra = Api.S.ConwayEra diff --git a/src/GeniusYield/Types/Key.hs b/src/GeniusYield/Types/Key.hs index 9a78bc94..6fcde731 100644 --- a/src/GeniusYield/Types/Key.hs +++ b/src/GeniusYield/Types/Key.hs @@ -1,122 +1,133 @@ -{-| +{- | Module : GeniusYield.Types.Key Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Types.Key - ( -- * Payment verification key - GYPaymentVerificationKey - , paymentVerificationKeyFromApi - , paymentVerificationKeyToApi - , paymentVerificationKeyToLedger - , paymentVerificationKeyRawBytes - , pubKeyHash - , paymentKeyHash - -- * Payment signing key - , GYPaymentSigningKey - , GYExtendedPaymentSigningKey - , paymentSigningKeyFromApi - , extendedPaymentSigningKeyFromApi - , paymentSigningKeyToApi - , extendedPaymentSigningKeyToApi - , paymentSigningKeyToLedger - , paymentSigningKeyToLedgerKeyPair - , paymentSigningKeyFromLedgerKeyPair - , readPaymentSigningKey - , readExtendedPaymentSigningKey - , writePaymentSigningKey - , writeExtendedPaymentSigningKey - , paymentVerificationKey - , generatePaymentSigningKey - -- * Stake verification key - , GYStakeVerificationKey - , stakeVerificationKeyFromApi - , stakeVerificationKeyToApi - , stakeKeyHash - , stakeVerificationKeyToLedger - -- * Stake signing key - , GYStakeSigningKey - , GYExtendedStakeSigningKey - , stakeSigningKeyFromApi - , extendedStakeSigningKeyFromApi - , stakeSigningKeyToApi - , extendedStakeSigningKeyToApi - , stakeSigningKeyToLedger - , stakeSigningKeyToLedgerKeyPair - , stakeSigningKeyFromLedgerKeyPair - , readStakeSigningKey - , readExtendedStakeSigningKey - , writeStakeSigningKey - , writeExtendedStakeSigningKey - , stakeVerificationKey - , generateStakeSigningKey - , GYSomeSigningKey (..) - , readSomeSigningKey - , GYSomePaymentSigningKey (..) - , readSomePaymentSigningKey - , somePaymentSigningKeyToSomeSigningKey +module GeniusYield.Types.Key ( + -- * Payment verification key + GYPaymentVerificationKey, + paymentVerificationKeyFromApi, + paymentVerificationKeyToApi, + paymentVerificationKeyToLedger, + paymentVerificationKeyRawBytes, + pubKeyHash, + paymentKeyHash, + + -- * Payment signing key + GYPaymentSigningKey, + GYExtendedPaymentSigningKey, + paymentSigningKeyFromApi, + extendedPaymentSigningKeyFromApi, + paymentSigningKeyToApi, + extendedPaymentSigningKeyToApi, + paymentSigningKeyToLedger, + paymentSigningKeyToLedgerKeyPair, + paymentSigningKeyFromLedgerKeyPair, + readPaymentSigningKey, + readExtendedPaymentSigningKey, + writePaymentSigningKey, + writeExtendedPaymentSigningKey, + paymentVerificationKey, + generatePaymentSigningKey, + + -- * Stake verification key + GYStakeVerificationKey, + stakeVerificationKeyFromApi, + stakeVerificationKeyToApi, + stakeKeyHash, + stakeVerificationKeyToLedger, + + -- * Stake signing key + GYStakeSigningKey, + GYExtendedStakeSigningKey, + stakeSigningKeyFromApi, + extendedStakeSigningKeyFromApi, + stakeSigningKeyToApi, + extendedStakeSigningKeyToApi, + stakeSigningKeyToLedger, + stakeSigningKeyToLedgerKeyPair, + stakeSigningKeyFromLedgerKeyPair, + readStakeSigningKey, + readExtendedStakeSigningKey, + writeStakeSigningKey, + writeExtendedStakeSigningKey, + stakeVerificationKey, + generateStakeSigningKey, + GYSomeSigningKey (..), + readSomeSigningKey, + GYSomePaymentSigningKey (..), + readSomePaymentSigningKey, + somePaymentSigningKeyToSomeSigningKey, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Ledger.Crypto as Ledger -import qualified Cardano.Ledger.Keys as Ledger -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Base16 as BS16 -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Csv as Csv -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Test.Cardano.Ledger.Core.KeyPair as TLedger -import qualified Text.Printf as Printf - -import GeniusYield.Imports -import GeniusYield.Types.Key.Class (ToShelleyWitnessSigningKey, - toShelleyWitnessSigningKey) -import GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash, - paymentKeyHashFromApi) -import GeniusYield.Types.PubKeyHash (GYPubKeyHash, - pubKeyHashFromApi) -import GeniusYield.Types.StakeKeyHash (GYStakeKeyHash, - stakeKeyHashFromApi) - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import Data.Either (isRight) --- >>> import qualified Text.Printf as Printf +import Cardano.Api qualified as Api +import Cardano.Ledger.Crypto qualified as Ledger +import Cardano.Ledger.Keys qualified as Ledger +import Data.Aeson qualified as Aeson +import Data.ByteString.Base16 qualified as BS16 +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.Csv qualified as Csv +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Test.Cardano.Ledger.Core.KeyPair qualified as TLedger +import Text.Printf qualified as Printf + +import GeniusYield.Imports +import GeniusYield.Types.Key.Class ( + ToShelleyWitnessSigningKey, + toShelleyWitnessSigningKey, + ) +import GeniusYield.Types.PaymentKeyHash ( + GYPaymentKeyHash, + paymentKeyHashFromApi, + ) +import GeniusYield.Types.PubKeyHash ( + GYPubKeyHash, + pubKeyHashFromApi, + ) +import GeniusYield.Types.StakeKeyHash ( + GYStakeKeyHash, + stakeKeyHashFromApi, + ) + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import Data.Either (isRight) +>>> import qualified Text.Printf as Printf +-} ------------------------------------------------------------------------------- -- Payment verification key (public) ------------------------------------------------------------------------------- --- | --- --- >>> "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYPaymentVerificationKey --- GYPaymentVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- +{- | + +>>> "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYPaymentVerificationKey +GYPaymentVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +-} newtype GYPaymentVerificationKey = GYPaymentVerificationKey (Api.VerificationKey Api.PaymentKey) - deriving stock Show - deriving newtype (Eq, IsString) - --- | --- --- >>> paymentVerificationKeyFromApi "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- GYPaymentVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- + deriving stock (Show) + deriving newtype (Eq, IsString) + +{- | + +>>> paymentVerificationKeyFromApi "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +GYPaymentVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +-} paymentVerificationKeyFromApi :: Api.VerificationKey Api.PaymentKey -> GYPaymentVerificationKey paymentVerificationKeyFromApi = coerce --- | --- --- >>> paymentVerificationKeyToApi "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- +{- | + +>>> paymentVerificationKeyToApi "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +"0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +-} paymentVerificationKeyToApi :: GYPaymentVerificationKey -> Api.VerificationKey Api.PaymentKey paymentVerificationKeyToApi = coerce @@ -132,93 +143,90 @@ pubKeyHash = pubKeyHashFromApi . Api.verificationKeyHash . paymentVerificationKe paymentKeyHash :: GYPaymentVerificationKey -> GYPaymentKeyHash paymentKeyHash = paymentKeyHashFromApi . Api.verificationKeyHash . paymentVerificationKeyToApi --- | --- --- >>> LBS8.putStrLn $ Aeson.encode ("0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYPaymentVerificationKey) --- "58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode ("0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYPaymentVerificationKey) +"58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +-} instance Aeson.ToJSON GYPaymentVerificationKey where - toJSON = Aeson.String . TE.decodeUtf8 . BS16.encode . Api.serialiseToCBOR . paymentVerificationKeyToApi - --- | --- --- >>> Aeson.eitherDecode @GYPaymentVerificationKey "\"58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605\"" --- Right (GYPaymentVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605") --- --- >>> Aeson.eitherDecode @GYPaymentVerificationKey "\"58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193zzz\"" --- Left "Error in $: invalid character at offset: 65" --- -instance Aeson.FromJSON GYPaymentVerificationKey where - parseJSON (Aeson.String t) = case BS16.decode $ BS8.pack $ T.unpack t of - Left err -> fail err - Right bs -> case Api.deserialiseFromCBOR (Api.AsVerificationKey Api.AsPaymentKey) bs of - Left err -> fail $ show err - Right skey -> return $ GYPaymentVerificationKey skey - parseJSON _ = fail "payment verification key expected" + toJSON = Aeson.String . TE.decodeUtf8 . BS16.encode . Api.serialiseToCBOR . paymentVerificationKeyToApi + +{- | +>>> Aeson.eitherDecode @GYPaymentVerificationKey "\"58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605\"" +Right (GYPaymentVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605") +>>> Aeson.eitherDecode @GYPaymentVerificationKey "\"58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193zzz\"" +Left "Error in $: invalid character at offset: 65" +-} +instance Aeson.FromJSON GYPaymentVerificationKey where + parseJSON (Aeson.String t) = case BS16.decode $ BS8.pack $ T.unpack t of + Left err -> fail err + Right bs -> case Api.deserialiseFromCBOR (Api.AsVerificationKey Api.AsPaymentKey) bs of + Left err -> fail $ show err + Right skey -> return $ GYPaymentVerificationKey skey + parseJSON _ = fail "payment verification key expected" --- | --- --- >>> Printf.printf "%s\n" ("0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYPaymentVerificationKey) --- 0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605 --- +{- | + +>>> Printf.printf "%s\n" ("0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYPaymentVerificationKey) +0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605 +-} instance Printf.PrintfArg GYPaymentVerificationKey where - formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . paymentVerificationKeyToApi + formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . paymentVerificationKeyToApi ------------------------------------------------------------------------------- -- Payment signing key (private) ------------------------------------------------------------------------------- --- | --- --- >>> "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYPaymentSigningKey --- GYPaymentSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- +{- | + +>>> "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYPaymentSigningKey +GYPaymentSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +-} newtype GYPaymentSigningKey = GYPaymentSigningKey (Api.SigningKey Api.PaymentKey) - deriving stock Show - deriving newtype IsString + deriving stock (Show) + deriving newtype (IsString) instance Eq GYPaymentSigningKey where - (==) = (==) `on` show + (==) = (==) `on` show instance Ord GYPaymentSigningKey where - compare = compare `on` show + compare = compare `on` show instance ToShelleyWitnessSigningKey GYPaymentSigningKey where toShelleyWitnessSigningKey (GYPaymentSigningKey skey) = Api.WitnessPaymentKey skey - -- Handle key for extended signing key newtype GYExtendedPaymentSigningKey = GYExtendedPaymentSigningKey (Api.SigningKey Api.PaymentExtendedKey) - deriving stock Show - deriving newtype IsString + deriving stock (Show) + deriving newtype (IsString) instance Eq GYExtendedPaymentSigningKey where - (==) = (==) `on` show + (==) = (==) `on` show instance Ord GYExtendedPaymentSigningKey where - compare = compare `on` show + compare = compare `on` show instance ToShelleyWitnessSigningKey GYExtendedPaymentSigningKey where toShelleyWitnessSigningKey (GYExtendedPaymentSigningKey skey) = Api.WitnessPaymentExtendedKey skey --- | --- --- >>> paymentSigningKeyFromApi "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- GYPaymentSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- +{- | + +>>> paymentSigningKeyFromApi "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +GYPaymentSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +-} paymentSigningKeyFromApi :: Api.SigningKey Api.PaymentKey -> GYPaymentSigningKey paymentSigningKeyFromApi = coerce extendedPaymentSigningKeyFromApi :: Api.SigningKey Api.PaymentExtendedKey -> GYExtendedPaymentSigningKey extendedPaymentSigningKeyFromApi = coerce --- | --- --- >>> paymentSigningKeyToApi "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- +{- | + +>>> paymentSigningKeyToApi "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +"5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +-} paymentSigningKeyToApi :: GYPaymentSigningKey -> Api.SigningKey Api.PaymentKey paymentSigningKeyToApi = coerce @@ -229,7 +237,8 @@ paymentSigningKeyToLedger :: GYPaymentSigningKey -> Ledger.SignKeyDSIGN Ledger.S paymentSigningKeyToLedger = coerce paymentSigningKeyToLedgerKeyPair :: GYPaymentSigningKey -> TLedger.KeyPair r Ledger.StandardCrypto -paymentSigningKeyToLedgerKeyPair skey = TLedger.KeyPair +paymentSigningKeyToLedgerKeyPair skey = + TLedger.KeyPair { TLedger.vKey = paymentVerificationKeyToLedger $ paymentVerificationKey skey , TLedger.sKey = paymentSigningKeyToLedger skey } @@ -238,128 +247,121 @@ paymentSigningKeyFromLedgerKeyPair :: TLedger.KeyPair r Ledger.StandardCrypto -> paymentSigningKeyFromLedgerKeyPair = coerce . TLedger.sKey -- | Reads a payment signing key from a file. --- readPaymentSigningKey :: FilePath -> IO GYPaymentSigningKey readPaymentSigningKey fp = do - s <- Api.readFileTextEnvelopeAnyOf acceptedTypes (Api.File fp) - case s of - Left err -> fail (show err) --- throws IOError - Right x -> return (GYPaymentSigningKey x) + s <- Api.readFileTextEnvelopeAnyOf acceptedTypes (Api.File fp) + case s of + Left err -> fail (show err) --- throws IOError + Right x -> return (GYPaymentSigningKey x) where acceptedTypes = - [ Api.FromSomeType (Api.AsSigningKey Api.AsGenesisUTxOKey) Api.castSigningKey - , Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id - ] + [ Api.FromSomeType (Api.AsSigningKey Api.AsGenesisUTxOKey) Api.castSigningKey + , Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id + ] -- | Reads extended payment signing key from file --- readExtendedPaymentSigningKey :: FilePath -> IO GYExtendedPaymentSigningKey readExtendedPaymentSigningKey fp = do - s <- Api.readFileTextEnvelope (Api.AsSigningKey Api.AsPaymentExtendedKey) (Api.File fp) - case s of - Left err -> fail (show err) --- throws IOError - Right x -> return $ GYExtendedPaymentSigningKey x + s <- Api.readFileTextEnvelope (Api.AsSigningKey Api.AsPaymentExtendedKey) (Api.File fp) + case s of + Left err -> fail (show err) --- throws IOError + Right x -> return $ GYExtendedPaymentSigningKey x -- | Writes a payment signing key to a file. --- writePaymentSigningKey :: FilePath -> GYPaymentSigningKey -> IO () writePaymentSigningKey file key = do - e <- Api.writeFileTextEnvelope (Api.File file) (Just "Payment Signing Key") $ paymentSigningKeyToApi key - case e of - Left (err :: Api.FileError ()) -> throwIO $ userError $ show err - Right () -> return () + e <- Api.writeFileTextEnvelope (Api.File file) (Just "Payment Signing Key") $ paymentSigningKeyToApi key + case e of + Left (err :: Api.FileError ()) -> throwIO $ userError $ show err + Right () -> return () -- | Writes a extended payment signing key to a file. --- writeExtendedPaymentSigningKey :: FilePath -> GYExtendedPaymentSigningKey -> IO () writeExtendedPaymentSigningKey file key = do - e <- Api.writeFileTextEnvelope (Api.File file) (Just "Extended Payment Signing Key") $ extendedPaymentSigningKeyToApi key - case e of - Left (err :: Api.FileError ()) -> throwIO $ userError $ show err - Right () -> return () - --- | --- --- >>> paymentVerificationKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- GYPaymentVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- + e <- Api.writeFileTextEnvelope (Api.File file) (Just "Extended Payment Signing Key") $ extendedPaymentSigningKeyToApi key + case e of + Left (err :: Api.FileError ()) -> throwIO $ userError $ show err + Right () -> return () + +{- | + +>>> paymentVerificationKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +GYPaymentVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +-} paymentVerificationKey :: GYPaymentSigningKey -> GYPaymentVerificationKey paymentVerificationKey = GYPaymentVerificationKey . Api.getVerificationKey . paymentSigningKeyToApi --- | --- --- >>> LBS8.putStrLn $ Aeson.encode ("5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYPaymentSigningKey) --- "58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode ("5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYPaymentSigningKey) +"58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +-} instance Aeson.ToJSON GYPaymentSigningKey where - toJSON = Aeson.String . TE.decodeUtf8 . BS16.encode . Api.serialiseToCBOR . paymentSigningKeyToApi - --- | --- --- >>> Aeson.eitherDecode @GYPaymentSigningKey "\"58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290\"" --- Right (GYPaymentSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290") --- --- >>> Aeson.eitherDecode @GYPaymentSigningKey "\"58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fceczzz\"" --- Left "Error in $: invalid character at offset: 65" --- -instance Aeson.FromJSON GYPaymentSigningKey where - parseJSON (Aeson.String t) = case BS16.decode $ BS8.pack $ T.unpack t of - Left err -> fail err - Right bs -> case Api.deserialiseFromCBOR (Api.AsSigningKey Api.AsPaymentKey) bs of - Left err -> fail $ show err - Right skey -> return $ GYPaymentSigningKey skey - parseJSON _ = fail "payment signing key expected" + toJSON = Aeson.String . TE.decodeUtf8 . BS16.encode . Api.serialiseToCBOR . paymentSigningKeyToApi + +{- | +>>> Aeson.eitherDecode @GYPaymentSigningKey "\"58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290\"" +Right (GYPaymentSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290") + +>>> Aeson.eitherDecode @GYPaymentSigningKey "\"58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fceczzz\"" +Left "Error in $: invalid character at offset: 65" +-} +instance Aeson.FromJSON GYPaymentSigningKey where + parseJSON (Aeson.String t) = case BS16.decode $ BS8.pack $ T.unpack t of + Left err -> fail err + Right bs -> case Api.deserialiseFromCBOR (Api.AsSigningKey Api.AsPaymentKey) bs of + Left err -> fail $ show err + Right skey -> return $ GYPaymentSigningKey skey + parseJSON _ = fail "payment signing key expected" instance Csv.ToField GYPaymentSigningKey where toField = LBS.toStrict . Aeson.encode instance Csv.FromField GYPaymentSigningKey where parseField k = - case Aeson.decode $ LBS.fromStrict k of - Just v -> pure v - Nothing -> fail $ "Error Parsing paymentSigningKey from CSV: " <> show k - --- | --- --- >>> Printf.printf "%s\n" ("5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYPaymentSigningKey) --- 5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290 --- + case Aeson.decode $ LBS.fromStrict k of + Just v -> pure v + Nothing -> fail $ "Error Parsing paymentSigningKey from CSV: " <> show k + +{- | + +>>> Printf.printf "%s\n" ("5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYPaymentSigningKey) +5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290 +-} instance Printf.PrintfArg GYPaymentSigningKey where - formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . paymentSigningKeyToApi + formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . paymentSigningKeyToApi -- | Generates a new random payment signing key. --- generatePaymentSigningKey :: IO GYPaymentSigningKey generatePaymentSigningKey = paymentSigningKeyFromApi <$> Api.generateSigningKey Api.AsPaymentKey - ------------------------------------------------------------------------------- -- Stake verification key (public) ------------------------------------------------------------------------------- --- | --- --- >>> "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYStakeVerificationKey --- GYStakeVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- +{- | + +>>> "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYStakeVerificationKey +GYStakeVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +-} newtype GYStakeVerificationKey = GYStakeVerificationKey (Api.VerificationKey Api.StakeKey) - deriving stock Show - deriving newtype (Eq, IsString) - --- | --- --- >>> stakeVerificationKeyFromApi "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- GYStakeVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- + deriving stock (Show) + deriving newtype (Eq, IsString) + +{- | + +>>> stakeVerificationKeyFromApi "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +GYStakeVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +-} stakeVerificationKeyFromApi :: Api.VerificationKey Api.StakeKey -> GYStakeVerificationKey stakeVerificationKeyFromApi = coerce --- | --- --- >>> stakeVerificationKeyToApi "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- +{- | + +>>> stakeVerificationKeyToApi "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +"0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +-} stakeVerificationKeyToApi :: GYStakeVerificationKey -> Api.VerificationKey Api.StakeKey stakeVerificationKeyToApi = coerce @@ -369,93 +371,90 @@ stakeVerificationKeyToLedger = coerce stakeKeyHash :: GYStakeVerificationKey -> GYStakeKeyHash stakeKeyHash = stakeKeyHashFromApi . Api.verificationKeyHash . stakeVerificationKeyToApi --- | --- --- >>> LBS8.putStrLn $ Aeson.encode ("0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYStakeVerificationKey) --- "58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode ("0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYStakeVerificationKey) +"58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +-} instance Aeson.ToJSON GYStakeVerificationKey where - toJSON = Aeson.String . TE.decodeUtf8 . BS16.encode . Api.serialiseToCBOR . stakeVerificationKeyToApi - --- | --- --- >>> Aeson.eitherDecode @GYStakeVerificationKey "\"58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605\"" --- Right (GYStakeVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605") --- --- >>> Aeson.eitherDecode @GYStakeVerificationKey "\"58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193zzz\"" --- Left "Error in $: invalid character at offset: 65" --- -instance Aeson.FromJSON GYStakeVerificationKey where - parseJSON (Aeson.String t) = case BS16.decode $ BS8.pack $ T.unpack t of - Left err -> fail err - Right bs -> case Api.deserialiseFromCBOR (Api.AsVerificationKey Api.AsStakeKey) bs of - Left err -> fail $ show err - Right skey -> return $ GYStakeVerificationKey skey - parseJSON _ = fail "stake verification key expected" + toJSON = Aeson.String . TE.decodeUtf8 . BS16.encode . Api.serialiseToCBOR . stakeVerificationKeyToApi +{- | +>>> Aeson.eitherDecode @GYStakeVerificationKey "\"58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605\"" +Right (GYStakeVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605") --- | --- --- >>> Printf.printf "%s\n" ("0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYStakeVerificationKey) --- 0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605 --- -instance Printf.PrintfArg GYStakeVerificationKey where - formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . stakeVerificationKeyToApi +>>> Aeson.eitherDecode @GYStakeVerificationKey "\"58200717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193zzz\"" +Left "Error in $: invalid character at offset: 65" +-} +instance Aeson.FromJSON GYStakeVerificationKey where + parseJSON (Aeson.String t) = case BS16.decode $ BS8.pack $ T.unpack t of + Left err -> fail err + Right bs -> case Api.deserialiseFromCBOR (Api.AsVerificationKey Api.AsStakeKey) bs of + Left err -> fail $ show err + Right skey -> return $ GYStakeVerificationKey skey + parseJSON _ = fail "stake verification key expected" +{- | + +>>> Printf.printf "%s\n" ("0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" :: GYStakeVerificationKey) +0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605 +-} +instance Printf.PrintfArg GYStakeVerificationKey where + formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . stakeVerificationKeyToApi ------------------------------------------------------------------------------- -- Stake signing key (private) ------------------------------------------------------------------------------- --- | --- --- >>> "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYStakeSigningKey --- GYStakeSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- +{- | + +>>> "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYStakeSigningKey +GYStakeSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +-} newtype GYStakeSigningKey = GYStakeSigningKey (Api.SigningKey Api.StakeKey) - deriving stock Show - deriving newtype IsString + deriving stock (Show) + deriving newtype (IsString) instance Eq GYStakeSigningKey where - (==) = (==) `on` show + (==) = (==) `on` show instance Ord GYStakeSigningKey where - compare = compare `on` show + compare = compare `on` show instance ToShelleyWitnessSigningKey GYStakeSigningKey where toShelleyWitnessSigningKey (GYStakeSigningKey skey) = Api.WitnessStakeKey skey -- Handle key for extended signing key newtype GYExtendedStakeSigningKey = GYExtendedStakeSigningKey (Api.SigningKey Api.StakeExtendedKey) - deriving stock Show - deriving newtype IsString + deriving stock (Show) + deriving newtype (IsString) instance Eq GYExtendedStakeSigningKey where - (==) = (==) `on` show + (==) = (==) `on` show instance Ord GYExtendedStakeSigningKey where - compare = compare `on` show + compare = compare `on` show instance ToShelleyWitnessSigningKey GYExtendedStakeSigningKey where toShelleyWitnessSigningKey (GYExtendedStakeSigningKey skey) = Api.WitnessStakeExtendedKey skey --- | --- --- >>> stakeSigningKeyFromApi "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- GYStakeSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- +{- | + +>>> stakeSigningKeyFromApi "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +GYStakeSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +-} stakeSigningKeyFromApi :: Api.SigningKey Api.StakeKey -> GYStakeSigningKey stakeSigningKeyFromApi = coerce extendedStakeSigningKeyFromApi :: Api.SigningKey Api.StakeExtendedKey -> GYExtendedStakeSigningKey extendedStakeSigningKeyFromApi = coerce --- | --- --- >>> stakeSigningKeyToApi "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- +{- | + +>>> stakeSigningKeyToApi "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +"5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +-} stakeSigningKeyToApi :: GYStakeSigningKey -> Api.SigningKey Api.StakeKey stakeSigningKeyToApi = coerce @@ -466,7 +465,8 @@ stakeSigningKeyToLedger :: GYStakeSigningKey -> Ledger.SignKeyDSIGN Ledger.Stand stakeSigningKeyToLedger = coerce stakeSigningKeyToLedgerKeyPair :: GYStakeSigningKey -> TLedger.KeyPair r Ledger.StandardCrypto -stakeSigningKeyToLedgerKeyPair skey = TLedger.KeyPair +stakeSigningKeyToLedgerKeyPair skey = + TLedger.KeyPair { TLedger.vKey = stakeVerificationKeyToLedger $ stakeVerificationKey skey , TLedger.sKey = stakeSigningKeyToLedger skey } @@ -475,93 +475,87 @@ stakeSigningKeyFromLedgerKeyPair :: TLedger.KeyPair r Ledger.StandardCrypto -> G stakeSigningKeyFromLedgerKeyPair = coerce . TLedger.sKey -- | Reads a stake signing key from a file. --- readStakeSigningKey :: FilePath -> IO GYStakeSigningKey readStakeSigningKey fp = do - s <- Api.readFileTextEnvelope (Api.AsSigningKey Api.AsStakeKey) (Api.File fp) - case s of - Left err -> fail (show err) --- throws IOError - Right x -> return (GYStakeSigningKey x) + s <- Api.readFileTextEnvelope (Api.AsSigningKey Api.AsStakeKey) (Api.File fp) + case s of + Left err -> fail (show err) --- throws IOError + Right x -> return (GYStakeSigningKey x) -- | Reads extended stake signing key from file --- readExtendedStakeSigningKey :: FilePath -> IO GYExtendedStakeSigningKey readExtendedStakeSigningKey fp = do - s <- Api.readFileTextEnvelope (Api.AsSigningKey Api.AsStakeExtendedKey) (Api.File fp) - case s of - Left err -> fail (show err) --- throws IOError - Right x -> return $ GYExtendedStakeSigningKey x + s <- Api.readFileTextEnvelope (Api.AsSigningKey Api.AsStakeExtendedKey) (Api.File fp) + case s of + Left err -> fail (show err) --- throws IOError + Right x -> return $ GYExtendedStakeSigningKey x -- | Writes a stake signing key to a file. --- writeStakeSigningKey :: FilePath -> GYStakeSigningKey -> IO () writeStakeSigningKey file key = do - e <- Api.writeFileTextEnvelope (Api.File file) (Just "Stake Signing Key") $ stakeSigningKeyToApi key - case e of - Left (err :: Api.FileError ()) -> throwIO $ userError $ show err - Right () -> return () + e <- Api.writeFileTextEnvelope (Api.File file) (Just "Stake Signing Key") $ stakeSigningKeyToApi key + case e of + Left (err :: Api.FileError ()) -> throwIO $ userError $ show err + Right () -> return () -- | Writes a extended stake signing key to a file. --- writeExtendedStakeSigningKey :: FilePath -> GYExtendedStakeSigningKey -> IO () writeExtendedStakeSigningKey file key = do - e <- Api.writeFileTextEnvelope (Api.File file) (Just "Extended Stake Signing Key") $ extendedStakeSigningKeyToApi key - case e of - Left (err :: Api.FileError ()) -> throwIO $ userError $ show err - Right () -> return () - --- | --- --- >>> stakeVerificationKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- GYStakeVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" --- + e <- Api.writeFileTextEnvelope (Api.File file) (Just "Extended Stake Signing Key") $ extendedStakeSigningKeyToApi key + case e of + Left (err :: Api.FileError ()) -> throwIO $ userError $ show err + Right () -> return () + +{- | + +>>> stakeVerificationKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +GYStakeVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" +-} stakeVerificationKey :: GYStakeSigningKey -> GYStakeVerificationKey stakeVerificationKey = GYStakeVerificationKey . Api.getVerificationKey . stakeSigningKeyToApi --- | --- --- >>> LBS8.putStrLn $ Aeson.encode ("5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYStakeSigningKey) --- "58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode ("5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYStakeSigningKey) +"58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" +-} instance Aeson.ToJSON GYStakeSigningKey where - toJSON = Aeson.String . TE.decodeUtf8 . BS16.encode . Api.serialiseToCBOR . stakeSigningKeyToApi - --- | --- --- >>> Aeson.eitherDecode @GYStakeSigningKey "\"58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290\"" --- Right (GYStakeSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290") --- --- >>> Aeson.eitherDecode @GYStakeSigningKey "\"58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fceczzz\"" --- Left "Error in $: invalid character at offset: 65" --- -instance Aeson.FromJSON GYStakeSigningKey where - parseJSON (Aeson.String t) = case BS16.decode $ BS8.pack $ T.unpack t of - Left err -> fail err - Right bs -> case Api.deserialiseFromCBOR (Api.AsSigningKey Api.AsStakeKey) bs of - Left err -> fail $ show err - Right skey -> return $ GYStakeSigningKey skey - parseJSON _ = fail "stake signing key expected" + toJSON = Aeson.String . TE.decodeUtf8 . BS16.encode . Api.serialiseToCBOR . stakeSigningKeyToApi + +{- | +>>> Aeson.eitherDecode @GYStakeSigningKey "\"58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290\"" +Right (GYStakeSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290") + +>>> Aeson.eitherDecode @GYStakeSigningKey "\"58205ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fceczzz\"" +Left "Error in $: invalid character at offset: 65" +-} +instance Aeson.FromJSON GYStakeSigningKey where + parseJSON (Aeson.String t) = case BS16.decode $ BS8.pack $ T.unpack t of + Left err -> fail err + Right bs -> case Api.deserialiseFromCBOR (Api.AsSigningKey Api.AsStakeKey) bs of + Left err -> fail $ show err + Right skey -> return $ GYStakeSigningKey skey + parseJSON _ = fail "stake signing key expected" instance Csv.ToField GYStakeSigningKey where toField = LBS.toStrict . Aeson.encode instance Csv.FromField GYStakeSigningKey where parseField k = - case Aeson.decode $ LBS.fromStrict k of - Just v -> pure v - Nothing -> fail $ "Error Parsing stakeSigningKey from CSV: " <> show k - --- | --- --- >>> Printf.printf "%s\n" ("5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYStakeSigningKey) --- 5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290 --- + case Aeson.decode $ LBS.fromStrict k of + Just v -> pure v + Nothing -> fail $ "Error Parsing stakeSigningKey from CSV: " <> show k + +{- | + +>>> Printf.printf "%s\n" ("5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" :: GYStakeSigningKey) +5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290 +-} instance Printf.PrintfArg GYStakeSigningKey where - formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . stakeSigningKeyToApi + formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . stakeSigningKeyToApi -- | Generates a new random stake signing key. --- generateStakeSigningKey :: IO GYStakeSigningKey generateStakeSigningKey = stakeSigningKeyFromApi <$> Api.generateSigningKey Api.AsStakeKey @@ -572,28 +566,32 @@ instance ToShelleyWitnessSigningKey GYSomeSigningKey where readSomeSigningKey :: FilePath -> IO GYSomeSigningKey readSomeSigningKey file = do - e <- Api.readFileTextEnvelopeAnyOf - [ Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) $ GYSomeSigningKey . paymentSigningKeyFromApi - , Api.FromSomeType (Api.AsSigningKey Api.AsPaymentExtendedKey) $ GYSomeSigningKey . extendedPaymentSigningKeyFromApi - , Api.FromSomeType (Api.AsSigningKey Api.AsStakeKey) $ GYSomeSigningKey . stakeSigningKeyFromApi - , Api.FromSomeType (Api.AsSigningKey Api.AsStakeExtendedKey) $ GYSomeSigningKey . extendedStakeSigningKeyFromApi - ] (Api.File file) - case e of - Left err -> throwIO $ userError $ show err - Right skey -> return skey + e <- + Api.readFileTextEnvelopeAnyOf + [ Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) $ GYSomeSigningKey . paymentSigningKeyFromApi + , Api.FromSomeType (Api.AsSigningKey Api.AsPaymentExtendedKey) $ GYSomeSigningKey . extendedPaymentSigningKeyFromApi + , Api.FromSomeType (Api.AsSigningKey Api.AsStakeKey) $ GYSomeSigningKey . stakeSigningKeyFromApi + , Api.FromSomeType (Api.AsSigningKey Api.AsStakeExtendedKey) $ GYSomeSigningKey . extendedStakeSigningKeyFromApi + ] + (Api.File file) + case e of + Left err -> throwIO $ userError $ show err + Right skey -> return skey data GYSomePaymentSigningKey = AGYPaymentSigningKey !GYPaymentSigningKey | AGYExtendedPaymentSigningKey !GYExtendedPaymentSigningKey deriving stock (Eq, Show, Ord) readSomePaymentSigningKey :: FilePath -> IO GYSomePaymentSigningKey readSomePaymentSigningKey file = do - e <- Api.readFileTextEnvelopeAnyOf - [ Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) $ AGYPaymentSigningKey . paymentSigningKeyFromApi - , Api.FromSomeType (Api.AsSigningKey Api.AsPaymentExtendedKey) $ AGYExtendedPaymentSigningKey . extendedPaymentSigningKeyFromApi - ] (Api.File file) - case e of - Left err -> throwIO $ userError $ show err - Right skey -> return skey + e <- + Api.readFileTextEnvelopeAnyOf + [ Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) $ AGYPaymentSigningKey . paymentSigningKeyFromApi + , Api.FromSomeType (Api.AsSigningKey Api.AsPaymentExtendedKey) $ AGYExtendedPaymentSigningKey . extendedPaymentSigningKeyFromApi + ] + (Api.File file) + case e of + Left err -> throwIO $ userError $ show err + Right skey -> return skey somePaymentSigningKeyToSomeSigningKey :: GYSomePaymentSigningKey -> GYSomeSigningKey somePaymentSigningKeyToSomeSigningKey (AGYPaymentSigningKey key) = GYSomeSigningKey key diff --git a/src/GeniusYield/Types/Key/Class.hs b/src/GeniusYield/Types/Key/Class.hs index 4374d34b..b9e6d5b6 100644 --- a/src/GeniusYield/Types/Key/Class.hs +++ b/src/GeniusYield/Types/Key/Class.hs @@ -1,17 +1,16 @@ -{-| +{- | Module : GeniusYield.Types.Key.Class Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Key.Class ( ToShelleyWitnessSigningKey, toShelleyWitnessSigningKey, ) where -import qualified Cardano.Api as Api +import Cardano.Api qualified as Api class ToShelleyWitnessSigningKey a where toShelleyWitnessSigningKey :: a -> Api.ShelleyWitnessSigningKey diff --git a/src/GeniusYield/Types/Ledger.hs b/src/GeniusYield/Types/Ledger.hs index 2f42d51d..c9ea2329 100644 --- a/src/GeniusYield/Types/Ledger.hs +++ b/src/GeniusYield/Types/Ledger.hs @@ -1,25 +1,24 @@ -{-| +{- | Module : GeniusYield.Types.Ledger Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Ledger (PlutusToCardanoError (..)) where -import Data.Text (Text) +import Data.Text (Text) -import qualified PlutusLedgerApi.V1.Address as Plutus +import PlutusLedgerApi.V1.Address qualified as Plutus {- | 'PlutusToCardanoError' is raised when using Plutus to Cardano API type conversion functions from plutus-ledger. It is a focused version of "Ledger.Tx.CardanoAPI.ToCardanoError". -} data PlutusToCardanoError - -- | Deserialization failed; tag indicates the type being deserialized. - = DeserialiseRawBytesError { ptceTag :: Text } - -- | Raised when trying to convert a stake ptr plutus address. - | StakePtrAddressUnsupported Plutus.Address - -- | Wildcard unhandled constructors; shouldn't happen usually. - | UnknownPlutusToCardanoError { ptceTag :: Text } - deriving stock Show + = -- | Deserialization failed; tag indicates the type being deserialized. + DeserialiseRawBytesError {ptceTag :: Text} + | -- | Raised when trying to convert a stake ptr plutus address. + StakePtrAddressUnsupported Plutus.Address + | -- | Wildcard unhandled constructors; shouldn't happen usually. + UnknownPlutusToCardanoError {ptceTag :: Text} + deriving stock (Show) diff --git a/src/GeniusYield/Types/Logging.hs b/src/GeniusYield/Types/Logging.hs index 1baef3cf..f823cf86 100644 --- a/src/GeniusYield/Types/Logging.hs +++ b/src/GeniusYield/Types/Logging.hs @@ -1,162 +1,173 @@ -{-| +{- | Module : GeniusYield.Types.Logging Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Types.Logging - ( -- * Severity - GYLogSeverity (..) - , logSeverityToKatip - -- * Verbosity - , GYLogVerbosity (..) - , logVerbosityToKatip - -- * Namespace - , GYLogNamespace - , logNamespaceFromKatip - , logNamespaceToKatip - -- * Log contexts - , GYLogContexts - , logContextsFromKatip - , logContextsToKatip - , addContext - , sl - , logContextsToS - -- * Log environment - , GYLogEnv - , logEnvFromKatip - , logEnvToKatip - , closeScribes - -- * Log configuration - , GYLogConfiguration (..) - , GYRawLog (..) - , RawLogger (..) - , unitRawLogger - , simpleRawLogger - , cfgAddNamespace - , cfgAddContext - , logRun - -- * Scribe Configuration - , GYLogScribeType (..) - , GYLogScribeConfig (..) - , LogSrc (..) - -- * Utilities - , prettyNamespace - , mkLogEnv - ) where - -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Aeson (Key) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Key as Key -import qualified Data.ByteString.Lazy.Char8 as LBS8 -import Data.List (intercalate, isSuffixOf) -import Data.Maybe (fromJust) -import Data.String.Conv (StringConv, toS) -import qualified Data.Text as Text -import GeniusYield.Imports -import GeniusYield.Providers.GCP (gcpFormatter) -import qualified GeniusYield.Providers.Sentry as Sentry -import GHC.Stack (withFrozenCallStack) -import qualified Katip as K -import qualified Katip.Core as KC -import Network.URI (URI (..), URIAuth (..), - parseURIReference) -import System.IO (stderr, stdout) -import qualified Text.Printf as Printf - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import Text.Printf (printf) --- >>> import Data.Text (Text) +module GeniusYield.Types.Logging ( + -- * Severity + GYLogSeverity (..), + logSeverityToKatip, + + -- * Verbosity + GYLogVerbosity (..), + logVerbosityToKatip, + + -- * Namespace + GYLogNamespace, + logNamespaceFromKatip, + logNamespaceToKatip, + + -- * Log contexts + GYLogContexts, + logContextsFromKatip, + logContextsToKatip, + addContext, + sl, + logContextsToS, + + -- * Log environment + GYLogEnv, + logEnvFromKatip, + logEnvToKatip, + closeScribes, + + -- * Log configuration + GYLogConfiguration (..), + GYRawLog (..), + RawLogger (..), + unitRawLogger, + simpleRawLogger, + cfgAddNamespace, + cfgAddContext, + logRun, + + -- * Scribe Configuration + GYLogScribeType (..), + GYLogScribeConfig (..), + LogSrc (..), + + -- * Utilities + prettyNamespace, + mkLogEnv, +) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Aeson (Key) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.List (intercalate, isSuffixOf) +import Data.Maybe (fromJust) +import Data.String.Conv (StringConv, toS) +import Data.Text qualified as Text +import GHC.Stack (withFrozenCallStack) +import GeniusYield.Imports +import GeniusYield.Providers.GCP (gcpFormatter) +import GeniusYield.Providers.Sentry qualified as Sentry +import Katip qualified as K +import Katip.Core qualified as KC +import Network.URI ( + URI (..), + URIAuth (..), + parseURIReference, + ) +import System.IO (stderr, stdout) +import Text.Printf qualified as Printf + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import Text.Printf (printf) +>>> import Data.Text (Text) +-} ------------------------------------------------------------------------------- -- Severity ------------------------------------------------------------------------------- --- | --- --- >>> LBS8.putStrLn $ Aeson.encode GYDebug --- "Debug" --- --- >>> LBS8.putStrLn $ Aeson.encode GYInfo --- "Info" --- --- >>> LBS8.putStrLn $ Aeson.encode GYWarning --- "Warning" --- --- >>> LBS8.putStrLn $ Aeson.encode GYError --- "Error" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode GYDebug +"Debug" + +>>> LBS8.putStrLn $ Aeson.encode GYInfo +"Info" + +>>> LBS8.putStrLn $ Aeson.encode GYWarning +"Warning" + +>>> LBS8.putStrLn $ Aeson.encode GYError +"Error" +-} data GYLogSeverity = GYDebug | GYInfo | GYWarning | GYError - deriving stock (Show, Read, Eq, Ord, Enum, Bounded) + deriving stock (Show, Read, Eq, Ord, Enum, Bounded) instance Aeson.ToJSON GYLogSeverity where - toJSON GYDebug = "Debug" - toJSON GYInfo = "Info" - toJSON GYWarning = "Warning" - toJSON GYError = "Error" - --- | --- --- >>> Aeson.eitherDecode @GYLogSeverity "\"Debug\"" --- Right GYDebug --- --- >>> Aeson.eitherDecode @GYLogSeverity "\"Info\"" --- Right GYInfo --- --- >>> Aeson.eitherDecode @GYLogSeverity "\"Warning\"" --- Right GYWarning --- --- >>> Aeson.eitherDecode @GYLogSeverity "\"Error\"" --- Right GYError --- --- >>> Aeson.eitherDecode @GYLogSeverity "\"Fatal\"" --- Left "Error in $: unknown GYLogSeverity: Fatal" --- + toJSON GYDebug = "Debug" + toJSON GYInfo = "Info" + toJSON GYWarning = "Warning" + toJSON GYError = "Error" + +{- | + +>>> Aeson.eitherDecode @GYLogSeverity "\"Debug\"" +Right GYDebug + +>>> Aeson.eitherDecode @GYLogSeverity "\"Info\"" +Right GYInfo + +>>> Aeson.eitherDecode @GYLogSeverity "\"Warning\"" +Right GYWarning + +>>> Aeson.eitherDecode @GYLogSeverity "\"Error\"" +Right GYError + +>>> Aeson.eitherDecode @GYLogSeverity "\"Fatal\"" +Left "Error in $: unknown GYLogSeverity: Fatal" +-} instance Aeson.FromJSON GYLogSeverity where - parseJSON = Aeson.withText "GYLogSeverity" $ \t -> - if | t == "Debug" -> return GYDebug - | t == "Info" -> return GYInfo - | t == "Warning" -> return GYWarning - | t == "Error" -> return GYError - | otherwise -> fail $ "unknown GYLogSeverity: " <> Text.unpack t + parseJSON = Aeson.withText "GYLogSeverity" $ \t -> + if + | t == "Debug" -> return GYDebug + | t == "Info" -> return GYInfo + | t == "Warning" -> return GYWarning + | t == "Error" -> return GYError + | otherwise -> fail $ "unknown GYLogSeverity: " <> Text.unpack t logSeverityToKatip :: GYLogSeverity -> K.Severity -logSeverityToKatip GYDebug = K.DebugS -logSeverityToKatip GYInfo = K.InfoS +logSeverityToKatip GYDebug = K.DebugS +logSeverityToKatip GYInfo = K.InfoS logSeverityToKatip GYWarning = K.WarningS -logSeverityToKatip GYError = K.ErrorS +logSeverityToKatip GYError = K.ErrorS ------------------------------------------------------------------------------- -- Verbosity ------------------------------------------------------------------------------- --- | --- --- >>> Aeson.eitherDecode @GYLogVerbosity "\"V0\"" --- Right (GYLogVerbosity V0) --- --- >>> Aeson.eitherDecode @GYLogVerbosity "\"V1\"" --- Right (GYLogVerbosity V1) --- --- >>> Aeson.eitherDecode @GYLogVerbosity "\"V2\"" --- Right (GYLogVerbosity V2) --- --- >>> Aeson.eitherDecode @GYLogVerbosity "\"V3\"" --- Right (GYLogVerbosity V3) --- --- >>> Aeson.eitherDecode @GYLogVerbosity "\"V4\"" --- Left "Error in $: Invalid Verbosity V4" --- +{- | + +>>> Aeson.eitherDecode @GYLogVerbosity "\"V0\"" +Right (GYLogVerbosity V0) + +>>> Aeson.eitherDecode @GYLogVerbosity "\"V1\"" +Right (GYLogVerbosity V1) + +>>> Aeson.eitherDecode @GYLogVerbosity "\"V2\"" +Right (GYLogVerbosity V2) + +>>> Aeson.eitherDecode @GYLogVerbosity "\"V3\"" +Right (GYLogVerbosity V3) + +>>> Aeson.eitherDecode @GYLogVerbosity "\"V4\"" +Left "Error in $: Invalid Verbosity V4" +-} newtype GYLogVerbosity = GYLogVerbosity K.Verbosity - deriving stock (Show, Read) - deriving newtype (Eq, Ord, Enum, Bounded, Aeson.FromJSON, Aeson.ToJSON) + deriving stock (Show, Read) + deriving newtype (Eq, Ord, Enum, Bounded, Aeson.FromJSON, Aeson.ToJSON) logVerbosityToKatip :: GYLogVerbosity -> K.Verbosity logVerbosityToKatip = coerce @@ -165,22 +176,22 @@ logVerbosityToKatip = coerce -- Namespace ------------------------------------------------------------------------------- --- | --- --- >>> "My" <> "Namespace" :: GYLogNamespace --- GYLogNamespace (Namespace {unNamespace = ["My","Namespace"]}) --- +{- | + +>>> "My" <> "Namespace" :: GYLogNamespace +GYLogNamespace (Namespace {unNamespace = ["My","Namespace"]}) +-} newtype GYLogNamespace = GYLogNamespace K.Namespace - deriving stock (Show, Read, Eq, Ord) - deriving newtype (Semigroup, Monoid, IsString) - --- | --- --- >>> printf "%s" ("My" <> "Namespace" :: GYLogNamespace) --- My.Namespace --- + deriving stock (Show, Read, Eq, Ord) + deriving newtype (Semigroup, Monoid, IsString) + +{- | + +>>> printf "%s" ("My" <> "Namespace" :: GYLogNamespace) +My.Namespace +-} instance Printf.PrintfArg GYLogNamespace where - formatArg ns = Printf.formatArg (prettyNamespace ns) + formatArg ns = Printf.formatArg (prettyNamespace ns) logNamespaceToKatip :: GYLogNamespace -> K.Namespace logNamespaceToKatip = coerce @@ -205,23 +216,23 @@ logContextsToKatip :: GYLogContexts -> K.LogContexts logContextsToKatip = coerce -- | Add a context to the log contexts. See `sl`. -addContext :: KC.LogItem i => i -> GYLogContexts -> GYLogContexts +addContext :: (KC.LogItem i) => i -> GYLogContexts -> GYLogContexts addContext i ctx = ctx <> logContextsFromKatip (K.liftPayload i) --- | Construct a simple log payload. --- --- >>> Aeson.encode $ logContextsToKatip $ addContext (sl "key" "value") mempty --- "{\"key\":\"value\"}" --- -sl :: forall a. ToJSON a => Text -> a -> K.SimpleLogPayload +{- | Construct a simple log payload. + +>>> Aeson.encode $ logContextsToKatip $ addContext (sl "key" "value") mempty +"{\"key\":\"value\"}" +-} +sl :: forall a. (ToJSON a) => Text -> a -> K.SimpleLogPayload sl = K.sl --- | Get textual representation of log contexts. --- --- >>> logContextsToS @Text $ addContext (sl "key" "value") mempty --- "{\"key\":\"value\"}" --- -logContextsToS :: StringConv LBS8.ByteString a => GYLogContexts -> a +{- | Get textual representation of log contexts. + +>>> logContextsToS @Text $ addContext (sl "key" "value") mempty +"{\"key\":\"value\"}" +-} +logContextsToS :: (StringConv LBS8.ByteString a) => GYLogContexts -> a logContextsToS = logContextsToKatip >>> Aeson.encode >>> toS ------------------------------------------------------------------------------- @@ -244,7 +255,7 @@ closeScribes genv = genv & logEnvToKatip & K.closeScribes <&> logEnvFromKatip -- Log configuration ------------------------------------------------------------------------------- -newtype RawLogger = RawLogger { unRawLogger :: GYLogContexts -> GYLogNamespace -> GYLogSeverity -> Text -> IO () } +newtype RawLogger = RawLogger {unRawLogger :: GYLogContexts -> GYLogNamespace -> GYLogSeverity -> Text -> IO ()} -- | A logger that does ignores the logs. unitRawLogger :: RawLogger @@ -255,21 +266,21 @@ simpleRawLogger :: GYLogSeverity -> (Text -> IO ()) -> RawLogger simpleRawLogger targetSev putLog = RawLogger $ \_ _ sev -> when (targetSev <= sev) . putLog data GYRawLog = GYRawLog - { rawLogRun :: RawLogger + { rawLogRun :: RawLogger , rawLogCleanUp :: IO () } data GYLogConfiguration = GYLogConfiguration { cfgLogNamespace :: !GYLogNamespace - , cfgLogContexts :: !GYLogContexts - , cfgLogDirector :: !(Either GYLogEnv GYRawLog) + , cfgLogContexts :: !GYLogContexts + , cfgLogDirector :: !(Either GYLogEnv GYRawLog) } cfgAddNamespace :: GYLogNamespace -> GYLogConfiguration -> GYLogConfiguration -cfgAddNamespace ns cfg = cfg { cfgLogNamespace = cfgLogNamespace cfg <> ns } +cfgAddNamespace ns cfg = cfg {cfgLogNamespace = cfgLogNamespace cfg <> ns} -cfgAddContext :: KC.LogItem i => i -> GYLogConfiguration -> GYLogConfiguration -cfgAddContext i cfg = cfg { cfgLogContexts = addContext i (cfgLogContexts cfg) } +cfgAddContext :: (KC.LogItem i) => i -> GYLogConfiguration -> GYLogConfiguration +cfgAddContext i cfg = cfg {cfgLogContexts = addContext i (cfgLogContexts cfg)} logRun :: (HasCallStack, MonadIO m, StringConv a Text) => GYLogConfiguration -> GYLogSeverity -> a -> m () logRun GYLogConfiguration {..} sev msg = case cfgLogDirector of @@ -284,122 +295,122 @@ newtype LogSrc = LogSrc URI deriving (Show, Eq, Ord) instance IsString LogSrc where - fromString s = LogSrc $ fromJust $ parseURIReference s + fromString s = LogSrc $ fromJust $ parseURIReference s instance Aeson.ToJSON LogSrc where - toEncoding (LogSrc s) = Aeson.toEncoding $ show s - toJSON (LogSrc s) = Aeson.toJSON $ show s + toEncoding (LogSrc s) = Aeson.toEncoding $ show s + toJSON (LogSrc s) = Aeson.toJSON $ show s instance Aeson.FromJSON LogSrc where parseJSON = Aeson.withText "LogSrc" $ \s -> do - case parseURIReference $ Text.unpack s of - Just u -> pure $ LogSrc u - _ -> fail $ "Invalid URI: " <> show s + case parseURIReference $ Text.unpack s of + Just u -> pure $ LogSrc u + _ -> fail $ "Invalid URI: " <> show s data GYLogScribeType = GYStdErrScribe | GYGCPScribe | GYCustomSourceScribe !LogSrc - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord) stdErrTag, gcpTag, typeTag, severityTag, verbosityTag, gySourceTag :: Key -stdErrTag = "stderr" -gcpTag = "gcp" -typeTag = "type" -severityTag = "severity" +stdErrTag = "stderr" +gcpTag = "gcp" +typeTag = "type" +severityTag = "severity" verbosityTag = "verbosity" -gySourceTag = "gySource" - - --- | --- --- >>> LBS8.putStrLn $ Aeson.encode GYStdErrScribe --- {"tag":"stderr"} --- --- >>> LBS8.putStrLn $ Aeson.encode $ GYCustomSourceScribe "https://pub:priv@sentry.hostname.tld:8443/sentry/example_project" --- {"tag":"gySource","source":"https://pub:...@sentry.hostname.tld:8443/sentry/example_project"} --- --- >>> LBS8.putStrLn $ Aeson.encode $ GYCustomSourceScribe "log.txt" --- {"tag":"gySource","source":"log.txt"} --- +gySourceTag = "gySource" + +{- | + +>>> LBS8.putStrLn $ Aeson.encode GYStdErrScribe +{"tag":"stderr"} + +>>> LBS8.putStrLn $ Aeson.encode $ GYCustomSourceScribe "https://pub:priv@sentry.hostname.tld:8443/sentry/example_project" +{"tag":"gySource","source":"https://pub:...@sentry.hostname.tld:8443/sentry/example_project"} + +>>> LBS8.putStrLn $ Aeson.encode $ GYCustomSourceScribe "log.txt" +{"tag":"gySource","source":"log.txt"} +-} instance Aeson.ToJSON GYLogScribeType where - toJSON GYStdErrScribe = Aeson.object ["tag" Aeson..= stdErrTag] - toJSON GYGCPScribe = Aeson.object ["tag" Aeson..= gcpTag] - toJSON (GYCustomSourceScribe source) = Aeson.object [ "tag" Aeson..= gySourceTag, "source" Aeson..= source] - - toEncoding GYStdErrScribe = Aeson.pairs ("tag" Aeson..= stdErrTag) - toEncoding GYGCPScribe = Aeson.pairs ("tag" Aeson..= gcpTag) - toEncoding (GYCustomSourceScribe source) = Aeson.pairs ("tag" Aeson..= gySourceTag <> "source" Aeson..= source) - --- | --- --- >>> Aeson.eitherDecode @GYLogScribeType "{\"tag\":\"stderr\"}" --- Right GYStdErrScribe --- --- >>> Aeson.eitherDecode @GYLogScribeType "{\"tag\":\"gySource\",\"source\":\"log.txt\"}" --- Right (GYCustomSourceScribe (LogSrc log.txt)) --- --- >>> Aeson.eitherDecode @GYLogScribeType "{\"tag\":\"gySource\",\"source\":\"https://pub:priv@sentry.hostname.tld:8443/sentry/example_project\"}" --- Right (GYCustomSourceScribe (LogSrc https://pub:...@sentry.hostname.tld:8443/sentry/example_project)) --- --- >>> Aeson.eitherDecode @GYLogScribeType "{\"tag\":\"fancy-scribe\"}" --- Left "Error in $: unknown GYLogScribe tag: fancy-scribe" --- + toJSON GYStdErrScribe = Aeson.object ["tag" Aeson..= stdErrTag] + toJSON GYGCPScribe = Aeson.object ["tag" Aeson..= gcpTag] + toJSON (GYCustomSourceScribe source) = Aeson.object ["tag" Aeson..= gySourceTag, "source" Aeson..= source] + + toEncoding GYStdErrScribe = Aeson.pairs ("tag" Aeson..= stdErrTag) + toEncoding GYGCPScribe = Aeson.pairs ("tag" Aeson..= gcpTag) + toEncoding (GYCustomSourceScribe source) = Aeson.pairs ("tag" Aeson..= gySourceTag <> "source" Aeson..= source) + +{- | + +>>> Aeson.eitherDecode @GYLogScribeType "{\"tag\":\"stderr\"}" +Right GYStdErrScribe + +>>> Aeson.eitherDecode @GYLogScribeType "{\"tag\":\"gySource\",\"source\":\"log.txt\"}" +Right (GYCustomSourceScribe (LogSrc log.txt)) + +>>> Aeson.eitherDecode @GYLogScribeType "{\"tag\":\"gySource\",\"source\":\"https://pub:priv@sentry.hostname.tld:8443/sentry/example_project\"}" +Right (GYCustomSourceScribe (LogSrc https://pub:...@sentry.hostname.tld:8443/sentry/example_project)) + +>>> Aeson.eitherDecode @GYLogScribeType "{\"tag\":\"fancy-scribe\"}" +Left "Error in $: unknown GYLogScribe tag: fancy-scribe" +-} instance Aeson.FromJSON GYLogScribeType where - parseJSON = Aeson.withObject "GYLogScribeType" $ \x -> do - tag <- x Aeson..: "tag" - if | tag == stdErrTag -> pure GYStdErrScribe - | tag == gcpTag -> pure GYGCPScribe - | tag == gySourceTag -> GYCustomSourceScribe <$> x Aeson..: "source" - | otherwise -> fail $ "unknown GYLogScribe tag: " <> Key.toString tag + parseJSON = Aeson.withObject "GYLogScribeType" $ \x -> do + tag <- x Aeson..: "tag" + if + | tag == stdErrTag -> pure GYStdErrScribe + | tag == gcpTag -> pure GYGCPScribe + | tag == gySourceTag -> GYCustomSourceScribe <$> x Aeson..: "source" + | otherwise -> fail $ "unknown GYLogScribe tag: " <> Key.toString tag data GYLogScribeConfig = GYLogScribeConfig - { cfgLogType :: !GYLogScribeType - , cfgLogSeverity :: !GYLogSeverity - , cfgLogVerbosity :: !GYLogVerbosity - } deriving (Show, Eq, Ord) - --- | --- --- >>> LBS8.putStrLn $ Aeson.encode $ GYLogScribeConfig (GYCustomSourceScribe "log.txt") GYWarning (read "GYLogVerbosity V1") --- {"type":{"tag":"gySource","source":"log.txt"},"severity":"Warning","verbosity":"V1"} --- + { cfgLogType :: !GYLogScribeType + , cfgLogSeverity :: !GYLogSeverity + , cfgLogVerbosity :: !GYLogVerbosity + } + deriving (Show, Eq, Ord) + +{- | + +>>> LBS8.putStrLn $ Aeson.encode $ GYLogScribeConfig (GYCustomSourceScribe "log.txt") GYWarning (read "GYLogVerbosity V1") +{"type":{"tag":"gySource","source":"log.txt"},"severity":"Warning","verbosity":"V1"} +-} instance Aeson.ToJSON GYLogScribeConfig where - toJSON GYLogScribeConfig {..} = Aeson.object - [ typeTag Aeson..= cfgLogType - , severityTag Aeson..= cfgLogSeverity - , verbosityTag Aeson..= cfgLogVerbosity - ] - - toEncoding GYLogScribeConfig {..} = Aeson.pairs - ( typeTag Aeson..= cfgLogType - <> severityTag Aeson..= cfgLogSeverity - <> verbosityTag Aeson..= cfgLogVerbosity - ) - - --- | --- --- >>> Aeson.decode @GYLogScribeConfig "{\"severity\":\"Warning\",\"verbosity\":\"V1\",\"type\":{\"tag\":\"gySource\",\"source\":\"log.txt\"}}" --- Just (GYLogScribeConfig {cfgLogType = GYCustomSourceScribe (LogSrc log.txt), cfgLogSeverity = GYWarning, cfgLogVerbosity = GYLogVerbosity V1}) --- + toJSON GYLogScribeConfig {..} = + Aeson.object + [ typeTag Aeson..= cfgLogType + , severityTag Aeson..= cfgLogSeverity + , verbosityTag Aeson..= cfgLogVerbosity + ] + + toEncoding GYLogScribeConfig {..} = + Aeson.pairs + ( typeTag Aeson..= cfgLogType + <> severityTag Aeson..= cfgLogSeverity + <> verbosityTag Aeson..= cfgLogVerbosity + ) + +{- | + +>>> Aeson.decode @GYLogScribeConfig "{\"severity\":\"Warning\",\"verbosity\":\"V1\",\"type\":{\"tag\":\"gySource\",\"source\":\"log.txt\"}}" +Just (GYLogScribeConfig {cfgLogType = GYCustomSourceScribe (LogSrc log.txt), cfgLogSeverity = GYWarning, cfgLogVerbosity = GYLogVerbosity V1}) +-} instance Aeson.FromJSON GYLogScribeConfig where - parseJSON = Aeson.withObject "GYLogScribeConfig" $ \x -> - GYLogScribeConfig <$> (x Aeson..: typeTag) - <*> (x Aeson..: severityTag) - <*> (x Aeson..: verbosityTag) + parseJSON = Aeson.withObject "GYLogScribeConfig" $ \x -> + GYLogScribeConfig + <$> (x Aeson..: typeTag) + <*> (x Aeson..: severityTag) + <*> (x Aeson..: verbosityTag) mkScribe :: GYLogScribeConfig -> IO (K.Scribe, Text.Text) mkScribe GYLogScribeConfig {..} = case cfgLogType of - GYStdErrScribe -> do - scribe <- K.mkHandleScribe K.ColorIfTerminal stderr permit verbosity - pure (scribe, "stderr") - - GYGCPScribe -> do - scribe <- K.mkHandleScribeWithFormatter gcpFormatter K.ColorIfTerminal stdout permit verbosity - pure (scribe, "gcp-stdout") - - GYCustomSourceScribe source -> do - scribe <- customSourceScribe source - pure (scribe, Text.pack $ show source) - + GYStdErrScribe -> do + scribe <- K.mkHandleScribe K.ColorIfTerminal stderr permit verbosity + pure (scribe, "stderr") + GYGCPScribe -> do + scribe <- K.mkHandleScribeWithFormatter gcpFormatter K.ColorIfTerminal stdout permit verbosity + pure (scribe, "gcp-stdout") + GYCustomSourceScribe source -> do + scribe <- customSourceScribe source + pure (scribe, Text.pack $ show source) where permit :: K.PermitFunc permit = K.permitItem $ logSeverityToKatip cfgLogSeverity @@ -411,19 +422,18 @@ mkScribe GYLogScribeConfig {..} = case cfgLogType of customSourceScribe (LogSrc uri) = case uri of URI {uriScheme = "", uriPath = path} -> K.mkFileScribe path permit verbosity - - URI {uriScheme = s, uriAuthority = Just URIAuth{uriRegName = domainName}} + URI {uriScheme = s, uriAuthority = Just URIAuth {uriRegName = domainName}} | s `elem` ["http:", "https:"] && "sentry.io" `isSuffixOf` domainName -> - Sentry.mkSentryScribe (Sentry.sentryService $ show uri) permit verbosity + Sentry.mkSentryScribe (Sentry.sentryService $ show uri) permit verbosity x -> fail $ "Unsupported LogSrc: " <> show x mkLogEnv :: GYLogNamespace -> [GYLogScribeConfig] -> IO GYLogEnv mkLogEnv ns cfgs = do - logEnv <- K.initLogEnv (logNamespaceToKatip $ "GeniusYield" <> ns) "" - logEnvFromKatip <$> foldM f logEnv cfgs + logEnv <- K.initLogEnv (logNamespaceToKatip $ "GeniusYield" <> ns) "" + logEnvFromKatip <$> foldM f logEnv cfgs where f :: K.LogEnv -> GYLogScribeConfig -> IO K.LogEnv f logEnv cfg = do - (scribe, name) <- mkScribe cfg - K.registerScribe name scribe K.defaultScribeSettings logEnv + (scribe, name) <- mkScribe cfg + K.registerScribe name scribe K.defaultScribeSettings logEnv diff --git a/src/GeniusYield/Types/Natural.hs b/src/GeniusYield/Types/Natural.hs index f8c626b4..59f97bd3 100644 --- a/src/GeniusYield/Types/Natural.hs +++ b/src/GeniusYield/Types/Natural.hs @@ -1,34 +1,34 @@ -{-| +{- | Module : GeniusYield.Types.Natural Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop +-} +module GeniusYield.Types.Natural ( + GYNatural, + naturalFromGHC, + naturalToGHC, +) where + +import GeniusYield.Imports + +import Control.Lens ((?~)) +import Data.Aeson qualified as Aeson +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Swagger.Lens qualified () +import Data.Text qualified as Text +import Web.HttpApiData qualified as Web +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import Data.Proxy +>>> import qualified Data.Swagger as Swagger -} -module GeniusYield.Types.Natural - ( GYNatural - , naturalFromGHC - , naturalToGHC - ) where - -import GeniusYield.Imports - -import Control.Lens ((?~)) -import qualified Data.Aeson as Aeson -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Swagger.Lens () -import qualified Data.Text as Text -import qualified Web.HttpApiData as Web - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import Data.Proxy --- >>> import qualified Data.Swagger as Swagger ------------------------------------------------------------------------------- -- GYNatural @@ -36,8 +36,8 @@ import qualified Web.HttpApiData as Web -- | Cardano allows token mint amount to be as large as @9_223_372_036_854_775_807@ which may not be represented correct in Javascript's @number@ type, consequently, such large integers are to be better given as text in JSON. This wrapper type around `Natural` gives modified `FromJSON` and `ToJSON` instances so to work with `Text` instead. newtype GYNatural = GYNatural Natural - deriving stock (Show, Read, Generic) - deriving newtype (Eq, Ord, Num, Real, Enum, Integral, PrintfArg, Web.FromHttpApiData, Web.ToHttpApiData) + deriving stock (Show, Read, Generic) + deriving newtype (Eq, Ord, Num, Real, Enum, Integral, PrintfArg, Web.FromHttpApiData, Web.ToHttpApiData) naturalFromGHC :: Natural -> GYNatural naturalFromGHC = coerce @@ -45,62 +45,66 @@ naturalFromGHC = coerce naturalToGHC :: GYNatural -> Natural naturalToGHC = coerce --- | --- --- >>> Aeson.decode @GYNatural "\"123\"" --- Just (GYNatural 123) --- --- >>> Aeson.eitherDecode @GYNatural "\"-123\"" --- Left "Error in $: underflow: -123 (should be a non-negative integer)" --- --- >>> Aeson.eitherDecode @GYNatural "\"+123\"" --- Right (GYNatural 123) --- --- >>> Aeson.eitherDecode @GYNatural "\"9223372036854775807\"" --- Right (GYNatural 9223372036854775807) --- --- >>> Aeson.eitherDecode @GYNatural "\"123456789123456789123456789123456789123456789\"" --- Right (GYNatural 123456789123456789123456789123456789123456789) --- --- >>> Aeson.eitherDecode @GYNatural "\"0011\"" --- Right (GYNatural 11) --- --- >>> Aeson.eitherDecode @GYNatural "\"0f11\"" --- Left "Error in $: could not parse: `0f11'" --- --- >>> Aeson.eitherDecode @GYNatural "\"-123456789123456789123456789123456789123456789\"" --- Left "Error in $: underflow: -123456789123456789123456789123456789123456789 (should be a non-negative integer)" --- +{- | + +>>> Aeson.decode @GYNatural "\"123\"" +Just (GYNatural 123) + +>>> Aeson.eitherDecode @GYNatural "\"-123\"" +Left "Error in $: underflow: -123 (should be a non-negative integer)" + +>>> Aeson.eitherDecode @GYNatural "\"+123\"" +Right (GYNatural 123) + +>>> Aeson.eitherDecode @GYNatural "\"9223372036854775807\"" +Right (GYNatural 9223372036854775807) + +>>> Aeson.eitherDecode @GYNatural "\"123456789123456789123456789123456789123456789\"" +Right (GYNatural 123456789123456789123456789123456789123456789) + +>>> Aeson.eitherDecode @GYNatural "\"0011\"" +Right (GYNatural 11) + +>>> Aeson.eitherDecode @GYNatural "\"0f11\"" +Left "Error in $: could not parse: `0f11'" + +>>> Aeson.eitherDecode @GYNatural "\"-123456789123456789123456789123456789123456789\"" +Left "Error in $: underflow: -123456789123456789123456789123456789123456789 (should be a non-negative integer)" +-} instance Aeson.FromJSON GYNatural where - parseJSON = Aeson.withText "GYNatural" $ \t -> - case Web.parseUrlPiece t of - Left err -> fail $ Text.unpack err - Right x -> return x - --- | --- --- >>> LBS8.putStrLn $ Aeson.encode (1234 :: GYNatural) --- "1234" --- --- >>> LBS8.putStrLn $ Aeson.encode (123456789123456789123456789123456789123456789 :: GYNatural) --- "123456789123456789123456789123456789123456789" --- + parseJSON = Aeson.withText "GYNatural" $ \t -> + case Web.parseUrlPiece t of + Left err -> fail $ Text.unpack err + Right x -> return x + +{- | + +>>> LBS8.putStrLn $ Aeson.encode (1234 :: GYNatural) +"1234" + +>>> LBS8.putStrLn $ Aeson.encode (123456789123456789123456789123456789123456789 :: GYNatural) +"123456789123456789123456789123456789123456789" +-} instance Aeson.ToJSON GYNatural where - toJSON = Aeson.toJSON . Web.toUrlPiece + toJSON = Aeson.toJSON . Web.toUrlPiece instance Swagger.ToParamSchema GYNatural where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - --- | --- --- >>> Aeson.encode (Swagger.toSchema (Proxy :: Proxy GYNatural)) --- "{\"description\":\"A natural number which is a non-negative integer. Minimum value is 0.\",\"example\":\"123456789123456789123456789123456789123456789\",\"type\":\"string\"}" --- + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + +{- | + +>>> Aeson.encode (Swagger.toSchema (Proxy :: Proxy GYNatural)) +"{\"description\":\"A natural number which is a non-negative integer. Minimum value is 0.\",\"example\":\"123456789123456789123456789123456789123456789\",\"type\":\"string\"}" +-} instance Swagger.ToSchema GYNatural where declareNamedSchema p = - pure $ Swagger.named "GYNatural" $ - Swagger.paramSchemaToSchema p - & Swagger.example ?~ toJSON ("123456789123456789123456789123456789123456789" :: String) - & Swagger.description ?~ "A natural number which is a non-negative integer. Minimum value is 0." - + pure $ + Swagger.named "GYNatural" $ + Swagger.paramSchemaToSchema p + & Swagger.example + ?~ toJSON ("123456789123456789123456789123456789123456789" :: String) + & Swagger.description + ?~ "A natural number which is a non-negative integer. Minimum value is 0." diff --git a/src/GeniusYield/Types/NetworkId.hs b/src/GeniusYield/Types/NetworkId.hs index 1a02be96..f503f229 100644 --- a/src/GeniusYield/Types/NetworkId.hs +++ b/src/GeniusYield/Types/NetworkId.hs @@ -1,102 +1,106 @@ -{-| +{- | Module : GeniusYield.Types.NetworkId Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Types.NetworkId - ( GYNetworkId (..) - , GYNetworkInfo (..) - , networkIdToApi - , networkIdToLedger - , networkIdToEpochSlots - ) where +module GeniusYield.Types.NetworkId ( + GYNetworkId (..), + GYNetworkInfo (..), + networkIdToApi, + networkIdToLedger, + networkIdToEpochSlots, +) where + +import Cardano.Api qualified as Api +import Cardano.Ledger.BaseTypes qualified as Ledger +import Data.Aeson.Types qualified as Aeson +import Data.Text qualified as T +import Data.Word (Word32, Word64) +import Deriving.Aeson -import qualified Cardano.Api as Api -import qualified Cardano.Ledger.BaseTypes as Ledger -import qualified Data.Aeson.Types as Aeson -import qualified Data.Text as T -import Data.Word (Word32, Word64) -import Deriving.Aeson +{- $setup --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +-} data GYNetworkId - = GYMainnet -- ^ cardano mainnet - | GYTestnetPreprod -- ^ cardano preprod testnet - | GYTestnetPreview -- ^ cardano preview testnet - | GYTestnetLegacy -- ^ cardano legacy testnet - | GYPrivnet !GYNetworkInfo -- ^ local private network - deriving (Show, Read, Eq, Ord) + = -- | cardano mainnet + GYMainnet + | -- | cardano preprod testnet + GYTestnetPreprod + | -- | cardano preview testnet + GYTestnetPreview + | -- | cardano legacy testnet + GYTestnetLegacy + | -- | local private network + GYPrivnet !GYNetworkInfo + deriving (Show, Read, Eq, Ord) networkIdToApi :: GYNetworkId -> Api.NetworkId -networkIdToApi GYMainnet = Api.Mainnet -networkIdToApi GYTestnetPreprod = Api.Testnet $ Api.NetworkMagic 1 -networkIdToApi GYTestnetPreview = Api.Testnet $ Api.NetworkMagic 2 -networkIdToApi GYTestnetLegacy = Api.Testnet $ Api.NetworkMagic 1097911063 +networkIdToApi GYMainnet = Api.Mainnet +networkIdToApi GYTestnetPreprod = Api.Testnet $ Api.NetworkMagic 1 +networkIdToApi GYTestnetPreview = Api.Testnet $ Api.NetworkMagic 2 +networkIdToApi GYTestnetLegacy = Api.Testnet $ Api.NetworkMagic 1097911063 networkIdToApi (GYPrivnet netInfo) = Api.Testnet . Api.NetworkMagic $ gyNetworkMagic netInfo networkIdToLedger :: GYNetworkId -> Ledger.Network networkIdToLedger nid = case networkIdToApi nid of - Api.Mainnet -> Ledger.Mainnet - Api.Testnet _magic -> Ledger.Testnet + Api.Mainnet -> Ledger.Mainnet + Api.Testnet _magic -> Ledger.Testnet networkIdToEpochSlots :: GYNetworkId -> Api.EpochSlots networkIdToEpochSlots (GYPrivnet netInfo) = Api.EpochSlots $ gyNetworkEpochSlots netInfo -networkIdToEpochSlots GYMainnet = Api.EpochSlots 432000 -networkIdToEpochSlots GYTestnetPreprod = Api.EpochSlots 432000 -networkIdToEpochSlots GYTestnetPreview = Api.EpochSlots 86400 -networkIdToEpochSlots GYTestnetLegacy = Api.EpochSlots 432000 +networkIdToEpochSlots GYMainnet = Api.EpochSlots 432000 +networkIdToEpochSlots GYTestnetPreprod = Api.EpochSlots 432000 +networkIdToEpochSlots GYTestnetPreview = Api.EpochSlots 86400 +networkIdToEpochSlots GYTestnetLegacy = Api.EpochSlots 432000 data GYNetworkInfo = GYNetworkInfo - { gyNetworkMagic :: !Word32 - , gyNetworkEpochSlots :: !Word64 - } - deriving (Show, Read, Eq, Ord, Generic) - deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "gy", CamelToSnake]] GYNetworkInfo - + { gyNetworkMagic :: !Word32 + , gyNetworkEpochSlots :: !Word64 + } + deriving (Show, Read, Eq, Ord, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "gy", CamelToSnake]] GYNetworkInfo ------------------------------------------------------------------------------- -- aeson ------------------------------------------------------------------------------- --- | --- --- >>> mapM_ LBS8.putStrLn $ Aeson.encode <$> [GYMainnet, GYTestnetPreprod, GYTestnetPreview, GYTestnetLegacy] --- "mainnet" --- "testnet-preprod" --- "testnet-preview" --- "testnet" --- +{- | + +>>> mapM_ LBS8.putStrLn $ Aeson.encode <$> [GYMainnet, GYTestnetPreprod, GYTestnetPreview, GYTestnetLegacy] +"mainnet" +"testnet-preprod" +"testnet-preview" +"testnet" +-} instance Aeson.ToJSON GYNetworkId where - toJSON GYMainnet = Aeson.toJSON ("mainnet" :: T.Text) - toJSON GYTestnetPreprod = Aeson.toJSON ("testnet-preprod" :: T.Text) - toJSON GYTestnetPreview = Aeson.toJSON ("testnet-preview" :: T.Text) - toJSON GYTestnetLegacy = Aeson.toJSON ("testnet" :: T.Text) - toJSON GYPrivnet{} = Aeson.toJSON ("privnet" :: T.Text) + toJSON GYMainnet = Aeson.toJSON ("mainnet" :: T.Text) + toJSON GYTestnetPreprod = Aeson.toJSON ("testnet-preprod" :: T.Text) + toJSON GYTestnetPreview = Aeson.toJSON ("testnet-preview" :: T.Text) + toJSON GYTestnetLegacy = Aeson.toJSON ("testnet" :: T.Text) + toJSON GYPrivnet {} = Aeson.toJSON ("privnet" :: T.Text) - toEncoding GYMainnet = Aeson.toEncoding ("mainnet" :: T.Text) - toEncoding GYTestnetPreprod = Aeson.toEncoding ("testnet-preprod" :: T.Text) - toEncoding GYTestnetPreview = Aeson.toEncoding ("testnet-preview" :: T.Text) - toEncoding GYTestnetLegacy = Aeson.toEncoding ("testnet" :: T.Text) - toEncoding GYPrivnet{} = Aeson.toEncoding ("privnet" :: T.Text) + toEncoding GYMainnet = Aeson.toEncoding ("mainnet" :: T.Text) + toEncoding GYTestnetPreprod = Aeson.toEncoding ("testnet-preprod" :: T.Text) + toEncoding GYTestnetPreview = Aeson.toEncoding ("testnet-preview" :: T.Text) + toEncoding GYTestnetLegacy = Aeson.toEncoding ("testnet" :: T.Text) + toEncoding GYPrivnet {} = Aeson.toEncoding ("privnet" :: T.Text) --- | --- --- >>> Aeson.eitherDecode @GYNetworkId <$> ["\"mainnet\"", "\"testnet-preprod\"", "\"preprod\"", "\"testnet-preview\"", "\"preview\"", "\"testnet\"", "\"no-such-net\""] --- [Right GYMainnet,Right GYTestnetPreprod,Right GYTestnetPreprod,Right GYTestnetPreview,Right GYTestnetPreview,Right GYTestnetLegacy,Left "Error in $: Expected mainnet, testnet-preprod, preprod, testnet-preview, preview or testnet"] --- +{- | + +>>> Aeson.eitherDecode @GYNetworkId <$> ["\"mainnet\"", "\"testnet-preprod\"", "\"preprod\"", "\"testnet-preview\"", "\"preview\"", "\"testnet\"", "\"no-such-net\""] +[Right GYMainnet,Right GYTestnetPreprod,Right GYTestnetPreprod,Right GYTestnetPreview,Right GYTestnetPreview,Right GYTestnetLegacy,Left "Error in $: Expected mainnet, testnet-preprod, preprod, testnet-preview, preview or testnet"] +-} instance Aeson.FromJSON GYNetworkId where - parseJSON "mainnet" = pure GYMainnet - parseJSON "testnet-preprod" = pure GYTestnetPreprod - parseJSON "preprod" = pure GYTestnetPreprod - parseJSON "testnet-preview" = pure GYTestnetPreview - parseJSON "preview" = pure GYTestnetPreview - parseJSON "testnet" = pure GYTestnetLegacy - parseJSON _ = fail "Expected mainnet, testnet-preprod, preprod, testnet-preview, preview or testnet" + parseJSON "mainnet" = pure GYMainnet + parseJSON "testnet-preprod" = pure GYTestnetPreprod + parseJSON "preprod" = pure GYTestnetPreprod + parseJSON "testnet-preview" = pure GYTestnetPreview + parseJSON "preview" = pure GYTestnetPreview + parseJSON "testnet" = pure GYTestnetLegacy + parseJSON _ = fail "Expected mainnet, testnet-preprod, preprod, testnet-preview, preview or testnet" diff --git a/src/GeniusYield/Types/OpenApi.hs b/src/GeniusYield/Types/OpenApi.hs index 690fc3f1..89ef5ffd 100644 --- a/src/GeniusYield/Types/OpenApi.hs +++ b/src/GeniusYield/Types/OpenApi.hs @@ -2,54 +2,52 @@ module GeniusYield.Types.OpenApi where -import Control.Lens ((&), (.~), (^.)) -import Data.Data (Typeable) -import Data.OpenApi (OpenApiType (..)) -import qualified Data.OpenApi as OpenApi -import qualified Data.OpenApi.Declare as OpenApi -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Declare as Swagger -import qualified Data.Swagger.Internal as Swagger +import Control.Lens ((&), (.~), (^.)) +import Data.Data (Typeable) +import Data.OpenApi (OpenApiType (..)) +import Data.OpenApi qualified as OpenApi +import Data.OpenApi.Declare qualified as OpenApi +import Data.Swagger qualified as Swagger +import Data.Swagger.Declare qualified as Swagger +import Data.Swagger.Internal qualified as Swagger -- | Lift a @Swagger.Schema@ to an @OpenApi.Schema@. liftSwaggerSchema :: Swagger.Schema -> OpenApi.Schema liftSwaggerSchema swaggerSchema = mempty - & OpenApi.title .~ swaggerSchema ^. Swagger.title - & OpenApi.description .~ swaggerSchema ^. Swagger.description - & OpenApi.required .~ swaggerSchema ^. Swagger.required - & OpenApi.allOf .~ (fmap convertSwaggerReferencedSchema <$> swaggerSchema ^. Swagger.allOf) - & OpenApi.properties .~ (convertSwaggerReferencedSchema <$> swaggerSchema ^. Swagger.properties) - & OpenApi.additionalProperties .~ (convertSwaggerAdditionalProperties <$> swaggerSchema ^. Swagger.additionalProperties) - & OpenApi.readOnly .~ swaggerSchema ^. Swagger.readOnly - & OpenApi.example .~ swaggerSchema ^. Swagger.example - & OpenApi.maxProperties .~ swaggerSchema ^. Swagger.maxProperties - & OpenApi.minProperties .~ swaggerSchema ^. Swagger.minProperties - & OpenApi.default_ .~ swaggerSchema ^. Swagger.default_ - & OpenApi.type_ .~ (convertSwaggerType <$> swaggerSchema ^. Swagger.type_) - & OpenApi.format .~ swaggerSchema ^. Swagger.format - & OpenApi.pattern .~ swaggerSchema ^. Swagger.pattern - & OpenApi.maximum_ .~ swaggerSchema ^. Swagger.maximum_ - & OpenApi.exclusiveMaximum .~ swaggerSchema ^. Swagger.exclusiveMaximum - & OpenApi.minimum_ .~ swaggerSchema ^. Swagger.minimum_ - & OpenApi.exclusiveMinimum .~ swaggerSchema ^. Swagger.exclusiveMinimum - & OpenApi.maxLength .~ swaggerSchema ^. Swagger.maxLength - & OpenApi.minLength .~ swaggerSchema ^. Swagger.minLength - & OpenApi.pattern .~ swaggerSchema ^. Swagger.pattern - & OpenApi.maxItems .~ swaggerSchema ^. Swagger.maxItems - & OpenApi.minItems .~ swaggerSchema ^. Swagger.minItems - & OpenApi.uniqueItems .~ swaggerSchema ^. Swagger.uniqueItems - & OpenApi.enum_ .~ swaggerSchema ^. Swagger.enum_ - & OpenApi.multipleOf .~ swaggerSchema ^. Swagger.multipleOf - & OpenApi.items .~ (convertSwaggerItems <$> swaggerSchema ^. Swagger.items) + & OpenApi.title .~ swaggerSchema ^. Swagger.title + & OpenApi.description .~ swaggerSchema ^. Swagger.description + & OpenApi.required .~ swaggerSchema ^. Swagger.required + & OpenApi.allOf .~ (fmap convertSwaggerReferencedSchema <$> swaggerSchema ^. Swagger.allOf) + & OpenApi.properties .~ (convertSwaggerReferencedSchema <$> swaggerSchema ^. Swagger.properties) + & OpenApi.additionalProperties .~ (convertSwaggerAdditionalProperties <$> swaggerSchema ^. Swagger.additionalProperties) + & OpenApi.readOnly .~ swaggerSchema ^. Swagger.readOnly + & OpenApi.example .~ swaggerSchema ^. Swagger.example + & OpenApi.maxProperties .~ swaggerSchema ^. Swagger.maxProperties + & OpenApi.minProperties .~ swaggerSchema ^. Swagger.minProperties + & OpenApi.default_ .~ swaggerSchema ^. Swagger.default_ + & OpenApi.type_ .~ (convertSwaggerType <$> swaggerSchema ^. Swagger.type_) + & OpenApi.format .~ swaggerSchema ^. Swagger.format + & OpenApi.pattern .~ swaggerSchema ^. Swagger.pattern + & OpenApi.maximum_ .~ swaggerSchema ^. Swagger.maximum_ + & OpenApi.exclusiveMaximum .~ swaggerSchema ^. Swagger.exclusiveMaximum + & OpenApi.minimum_ .~ swaggerSchema ^. Swagger.minimum_ + & OpenApi.exclusiveMinimum .~ swaggerSchema ^. Swagger.exclusiveMinimum + & OpenApi.maxLength .~ swaggerSchema ^. Swagger.maxLength + & OpenApi.minLength .~ swaggerSchema ^. Swagger.minLength + & OpenApi.pattern .~ swaggerSchema ^. Swagger.pattern + & OpenApi.maxItems .~ swaggerSchema ^. Swagger.maxItems + & OpenApi.minItems .~ swaggerSchema ^. Swagger.minItems + & OpenApi.uniqueItems .~ swaggerSchema ^. Swagger.uniqueItems + & OpenApi.enum_ .~ swaggerSchema ^. Swagger.enum_ + & OpenApi.multipleOf .~ swaggerSchema ^. Swagger.multipleOf + & OpenApi.items .~ (convertSwaggerItems <$> swaggerSchema ^. Swagger.items) where - convertSwaggerItems :: Swagger.SwaggerItems Swagger.SwaggerKindSchema -> OpenApi.OpenApiItems convertSwaggerItems (Swagger.SwaggerItemsObject s) = OpenApi.OpenApiItemsObject (convertSwaggerReferencedSchema s) convertSwaggerItems (Swagger.SwaggerItemsArray s) = OpenApi.OpenApiItemsArray (convertSwaggerReferencedSchema <$> s) convertSwaggerItems (Swagger.SwaggerItemsPrimitive _ _) = error "Primitive array items found in schema description, but should only be used for query params, headers and path pieces" - convertSwaggerReferencedSchema :: Swagger.Referenced Swagger.Schema -> OpenApi.Referenced OpenApi.Schema convertSwaggerReferencedSchema (Swagger.Inline s) = OpenApi.Inline (liftSwaggerSchema s) convertSwaggerReferencedSchema (Swagger.Ref r) = OpenApi.Ref (convertSwaggerRef r) @@ -58,13 +56,13 @@ liftSwaggerSchema swaggerSchema = convertSwaggerRef (Swagger.Reference ref) = OpenApi.Reference ref convertSwaggerType :: Swagger.SwaggerType 'Swagger.SwaggerKindSchema -> OpenApiType - convertSwaggerType Swagger.SwaggerString = OpenApiString - convertSwaggerType Swagger.SwaggerNumber = OpenApiNumber + convertSwaggerType Swagger.SwaggerString = OpenApiString + convertSwaggerType Swagger.SwaggerNumber = OpenApiNumber convertSwaggerType Swagger.SwaggerInteger = OpenApiInteger convertSwaggerType Swagger.SwaggerBoolean = OpenApiBoolean - convertSwaggerType Swagger.SwaggerArray = OpenApiArray - convertSwaggerType Swagger.SwaggerNull = OpenApiNull - convertSwaggerType Swagger.SwaggerObject = OpenApiObject + convertSwaggerType Swagger.SwaggerArray = OpenApiArray + convertSwaggerType Swagger.SwaggerNull = OpenApiNull + convertSwaggerType Swagger.SwaggerObject = OpenApiObject convertSwaggerAdditionalProperties :: Swagger.AdditionalProperties -> OpenApi.AdditionalProperties convertSwaggerAdditionalProperties (Swagger.AdditionalPropertiesAllowed b) = OpenApi.AdditionalPropertiesAllowed b @@ -80,7 +78,7 @@ liftSwaggerDec swaggerDeclare = let (swaggerSchemas, swaggerNamedSchema) = Swagger.runDeclare swaggerDeclare mempty openApiNamedSchema = convertNamedSchema swaggerNamedSchema openApiSchemas = liftSwaggerSchema <$> swaggerSchemas - in OpenApi.DeclareT $ \_ -> pure (openApiSchemas, openApiNamedSchema) + in OpenApi.DeclareT $ \_ -> pure (openApiSchemas, openApiNamedSchema) instance {-# OVERLAPPABLE #-} (Swagger.ToSchema a, Typeable a) => OpenApi.ToSchema a where declareNamedSchema p = liftSwaggerDec (Swagger.declareNamedSchema p) diff --git a/src/GeniusYield/Types/PaymentKeyHash.hs b/src/GeniusYield/Types/PaymentKeyHash.hs index cfc4d6a6..9c90da2f 100644 --- a/src/GeniusYield/Types/PaymentKeyHash.hs +++ b/src/GeniusYield/Types/PaymentKeyHash.hs @@ -1,52 +1,55 @@ -{-| +{- | Module : GeniusYield.Types.PaymentKeyHash Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.PaymentKeyHash ( - GYPaymentKeyHash, - paymentKeyHashFromPlutus, - paymentKeyHashToPlutus, - paymentKeyHashToApi, - paymentKeyHashFromApi, - paymentKeyHashFromLedger, - paymentKeyHashToLedger, + GYPaymentKeyHash, + paymentKeyHashFromPlutus, + paymentKeyHashToPlutus, + paymentKeyHashToApi, + paymentKeyHashFromApi, + paymentKeyHashFromLedger, + paymentKeyHashToLedger, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Keys.Shelley as Api -import qualified Cardano.Api.Ledger as Ledger -import Control.Lens ((?~)) -import qualified Data.Aeson.Types as Aeson -import qualified Data.Csv as Csv -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import GeniusYield.Imports -import GeniusYield.Types.Ledger -import GeniusYield.Types.PubKeyHash (AsPubKeyHash (..), CanSignTx, - pubKeyHashFromApi, - pubKeyHashToApi) -import qualified PlutusLedgerApi.V1.Crypto as Plutus -import qualified PlutusTx.Builtins as Plutus -import qualified PlutusTx.Builtins.Internal as Plutus -import qualified Text.Printf as Printf - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import qualified Data.Csv as Csv --- >>> import qualified Text.Printf as Printf +import Cardano.Api qualified as Api +import Cardano.Api.Keys.Shelley qualified as Api +import Cardano.Api.Ledger qualified as Ledger +import Control.Lens ((?~)) +import Data.Aeson.Types qualified as Aeson +import Data.Csv qualified as Csv +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import GeniusYield.Imports +import GeniusYield.Types.Ledger +import GeniusYield.Types.PubKeyHash ( + AsPubKeyHash (..), + CanSignTx, + pubKeyHashFromApi, + pubKeyHashToApi, + ) +import PlutusLedgerApi.V1.Crypto qualified as Plutus +import PlutusTx.Builtins qualified as Plutus +import PlutusTx.Builtins.Internal qualified as Plutus +import Text.Printf qualified as Printf + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import qualified Data.Csv as Csv +>>> import qualified Text.Printf as Printf +-} newtype GYPaymentKeyHash = GYPaymentKeyHash (Api.Hash Api.PaymentKey) - deriving stock Show - deriving newtype (Eq, Ord, IsString) + deriving stock (Show) + deriving newtype (Eq, Ord, IsString) instance AsPubKeyHash GYPaymentKeyHash where toPubKeyHash = paymentKeyHashToApi >>> pubKeyHashFromApi @@ -54,47 +57,48 @@ instance AsPubKeyHash GYPaymentKeyHash where instance CanSignTx GYPaymentKeyHash --- | --- --- >>> paymentKeyHashFromPlutus "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- Right (GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") --- --- >>> paymentKeyHashFromPlutus "abcd" --- Left (DeserialiseRawBytesError {ptceTag = "paymentKeyHashFromPlutus \"\\171\\205\", error: SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise Hash PaymentKey\"}"}) --- +{- | + +>>> paymentKeyHashFromPlutus "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +Right (GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") + +>>> paymentKeyHashFromPlutus "abcd" +Left (DeserialiseRawBytesError {ptceTag = "paymentKeyHashFromPlutus \"\\171\\205\", error: SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise Hash PaymentKey\"}"}) +-} paymentKeyHashFromPlutus :: Plutus.PubKeyHash -> Either PlutusToCardanoError GYPaymentKeyHash paymentKeyHashFromPlutus (Plutus.PubKeyHash (Plutus.BuiltinByteString h)) = - bimap - (\e -> DeserialiseRawBytesError $ Text.pack $ "paymentKeyHashFromPlutus " ++ show h ++ ", error: " ++ show e) - GYPaymentKeyHash + bimap + (\e -> DeserialiseRawBytesError $ Text.pack $ "paymentKeyHashFromPlutus " ++ show h ++ ", error: " ++ show e) + GYPaymentKeyHash $ Api.deserialiseFromRawBytes (Api.AsHash Api.AsPaymentKey) h --- | --- --- >>> let Just pkh = Aeson.decode @GYPaymentKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" --- >>> paymentKeyHashToPlutus pkh --- e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d --- +{- | + +>>> let Just pkh = Aeson.decode @GYPaymentKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" +>>> paymentKeyHashToPlutus pkh +e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d +-} paymentKeyHashToPlutus :: GYPaymentKeyHash -> Plutus.PubKeyHash -paymentKeyHashToPlutus = coerce fromCardanoPaymentKeyHash where +paymentKeyHashToPlutus = coerce fromCardanoPaymentKeyHash + where -- this is not exported from plutus-ledger fromCardanoPaymentKeyHash :: Api.Hash Api.PaymentKey -> Plutus.PubKeyHash fromCardanoPaymentKeyHash paymentKeyHash = Plutus.PubKeyHash $ Plutus.toBuiltin $ Api.serialiseToRawBytes paymentKeyHash --- | --- --- >>> let Just pkh = Aeson.decode @GYPaymentKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" --- >>> paymentKeyHashToApi pkh --- "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- +{- | + +>>> let Just pkh = Aeson.decode @GYPaymentKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" +>>> paymentKeyHashToApi pkh +"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +-} paymentKeyHashToApi :: GYPaymentKeyHash -> Api.Hash Api.PaymentKey paymentKeyHashToApi = coerce --- | --- --- >>> paymentKeyHashFromApi "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- +{- | + +>>> paymentKeyHashFromApi "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +-} paymentKeyHashFromApi :: Api.Hash Api.PaymentKey -> GYPaymentKeyHash paymentKeyHashFromApi = coerce @@ -106,69 +110,79 @@ paymentKeyHashToLedger = paymentKeyHashToApi >>> Api.unPaymentKeyHash paymentKeyHashFromLedger :: Ledger.KeyHash Ledger.Payment Ledger.StandardCrypto -> GYPaymentKeyHash paymentKeyHashFromLedger = Api.PaymentKeyHash >>> paymentKeyHashFromApi --- | --- --- >>> let Just pkh = Aeson.decode @GYPaymentKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" --- >>> LBS8.putStrLn $ Aeson.encode pkh --- "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- +{- | + +>>> let Just pkh = Aeson.decode @GYPaymentKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" +>>> LBS8.putStrLn $ Aeson.encode pkh +"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +-} instance Aeson.ToJSON GYPaymentKeyHash where - toJSON = Aeson.toJSON . Api.serialiseToRawBytesHexText . paymentKeyHashToApi - --- | --- --- >>> Aeson.eitherDecode @GYPaymentKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" --- Right (GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") --- --- Invalid characters: --- --- >>> Aeson.eitherDecode @GYPaymentKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6azzz\"" --- Left "Error in $: RawBytesHexErrorBase16DecodeFail \"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6azzz\" \"invalid character at offset: 53\"" --- + toJSON = Aeson.toJSON . Api.serialiseToRawBytesHexText . paymentKeyHashToApi + +{- | + +>>> Aeson.eitherDecode @GYPaymentKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" +Right (GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") + +Invalid characters: + +>>> Aeson.eitherDecode @GYPaymentKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6azzz\"" +Left "Error in $: RawBytesHexErrorBase16DecodeFail \"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6azzz\" \"invalid character at offset: 53\"" +-} instance Aeson.FromJSON GYPaymentKeyHash where - parseJSON = Aeson.withText "GYPaymentKeyHash" $ - either - (fail . show) - (return . GYPaymentKeyHash) + parseJSON = + Aeson.withText "GYPaymentKeyHash" $ + either + (fail . show) + (return . GYPaymentKeyHash) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsPaymentKey) . Text.encodeUtf8 --- | --- --- >>> Printf.printf "%s\n" $ paymentKeyHashFromApi "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d --- +{- | + +>>> Printf.printf "%s\n" $ paymentKeyHashFromApi "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d +-} instance Printf.PrintfArg GYPaymentKeyHash where - formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . paymentKeyHashToApi + formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . paymentKeyHashToApi --- | --- --- >>> Csv.toField @GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- +{- | + +>>> Csv.toField @GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +-} instance Csv.ToField GYPaymentKeyHash where - toField = Api.serialiseToRawBytesHex . paymentKeyHashToApi - --- | --- --- >>> Csv.runParser $ Csv.parseField @GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- Right (GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") --- --- >>> Csv.runParser $ Csv.parseField @GYPaymentKeyHash "not a payment key hash" --- Left "RawBytesHexErrorBase16DecodeFail \"not a payment key hash\" \"invalid character at offset: 0\"" --- + toField = Api.serialiseToRawBytesHex . paymentKeyHashToApi + +{- | + +>>> Csv.runParser $ Csv.parseField @GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +Right (GYPaymentKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") + +>>> Csv.runParser $ Csv.parseField @GYPaymentKeyHash "not a payment key hash" +Left "RawBytesHexErrorBase16DecodeFail \"not a payment key hash\" \"invalid character at offset: 0\"" +-} instance Csv.FromField GYPaymentKeyHash where - parseField = either (fail . show) (return . paymentKeyHashFromApi) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsPaymentKey) + parseField = either (fail . show) (return . paymentKeyHashFromApi) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsPaymentKey) ------------------------------------------------------------------------------- -- swagger schema ------------------------------------------------------------------------------- instance Swagger.ToSchema GYPaymentKeyHash where - declareNamedSchema _ = pure $ Swagger.named "GYPaymentKeyHash" $ mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "hex" - & Swagger.description ?~ "The hash of a payment public key." - & Swagger.example ?~ toJSON ("e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" :: Text) - & Swagger.maxLength ?~ 56 - & Swagger.minLength ?~ 56 + declareNamedSchema _ = + pure $ + Swagger.named "GYPaymentKeyHash" $ + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "hex" + & Swagger.description + ?~ "The hash of a payment public key." + & Swagger.example + ?~ toJSON ("e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" :: Text) + & Swagger.maxLength + ?~ 56 + & Swagger.minLength + ?~ 56 diff --git a/src/GeniusYield/Types/PlutusVersion.hs b/src/GeniusYield/Types/PlutusVersion.hs index 0a4e2643..5dd6c4fa 100644 --- a/src/GeniusYield/Types/PlutusVersion.hs +++ b/src/GeniusYield/Types/PlutusVersion.hs @@ -1,65 +1,64 @@ -{-| +{- | Module : GeniusYield.Types.PlutusVersion Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.PlutusVersion ( - -- * Plutus version - PlutusVersion (..), - SingPlutusVersion (..), - SingPlutusVersionI (..), - fromSingPlutusVersion, - PlutusVersionToApi, - singPlutusVersionToApi, - VersionIsGreaterOrEqual, - VersionIsGreater, - CmpPlutusVersion, + -- * Plutus version + PlutusVersion (..), + SingPlutusVersion (..), + SingPlutusVersionI (..), + fromSingPlutusVersion, + PlutusVersionToApi, + singPlutusVersionToApi, + VersionIsGreaterOrEqual, + VersionIsGreater, + CmpPlutusVersion, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import Data.GADT.Compare -import GeniusYield.Imports + +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Data.GADT.Compare +import GeniusYield.Imports data PlutusVersion - = PlutusV1 - | PlutusV2 - | PlutusV3 + = PlutusV1 + | PlutusV2 + | PlutusV3 deriving (Eq, Ord, Show) data SingPlutusVersion (v :: PlutusVersion) where - SingPlutusV1 :: SingPlutusVersion 'PlutusV1 - SingPlutusV2 :: SingPlutusVersion 'PlutusV2 - SingPlutusV3 :: SingPlutusVersion 'PlutusV3 - + SingPlutusV1 :: SingPlutusVersion 'PlutusV1 + SingPlutusV2 :: SingPlutusVersion 'PlutusV2 + SingPlutusV3 :: SingPlutusVersion 'PlutusV3 -class SingPlutusVersionI (v :: PlutusVersion) where singPlutusVersion :: SingPlutusVersion v -instance SingPlutusVersionI 'PlutusV1 where singPlutusVersion = SingPlutusV1 -instance SingPlutusVersionI 'PlutusV2 where singPlutusVersion = SingPlutusV2 -instance SingPlutusVersionI 'PlutusV3 where singPlutusVersion = SingPlutusV3 +class SingPlutusVersionI (v :: PlutusVersion) where singPlutusVersion :: SingPlutusVersion v +instance SingPlutusVersionI 'PlutusV1 where singPlutusVersion = SingPlutusV1 +instance SingPlutusVersionI 'PlutusV2 where singPlutusVersion = SingPlutusV2 +instance SingPlutusVersionI 'PlutusV3 where singPlutusVersion = SingPlutusV3 instance GEq SingPlutusVersion where - geq SingPlutusV1 SingPlutusV1 = Just Refl - geq SingPlutusV2 SingPlutusV2 = Just Refl - geq SingPlutusV3 SingPlutusV3 = Just Refl - geq _ _ = Nothing + geq SingPlutusV1 SingPlutusV1 = Just Refl + geq SingPlutusV2 SingPlutusV2 = Just Refl + geq SingPlutusV3 SingPlutusV3 = Just Refl + geq _ _ = Nothing instance GCompare SingPlutusVersion where - gcompare SingPlutusV1 SingPlutusV1 = GEQ - gcompare SingPlutusV1 _ = GLT - gcompare SingPlutusV2 SingPlutusV1 = GGT - gcompare SingPlutusV2 SingPlutusV2 = GEQ - gcompare SingPlutusV2 _ = GLT - gcompare SingPlutusV3 SingPlutusV1 = GGT - gcompare SingPlutusV3 SingPlutusV2 = GGT - gcompare SingPlutusV3 SingPlutusV3 = GEQ + gcompare SingPlutusV1 SingPlutusV1 = GEQ + gcompare SingPlutusV1 _ = GLT + gcompare SingPlutusV2 SingPlutusV1 = GGT + gcompare SingPlutusV2 SingPlutusV2 = GEQ + gcompare SingPlutusV2 _ = GLT + gcompare SingPlutusV3 SingPlutusV1 = GGT + gcompare SingPlutusV3 SingPlutusV2 = GGT + gcompare SingPlutusV3 SingPlutusV3 = GEQ type family PlutusVersionToApi (v :: PlutusVersion) :: Type where - PlutusVersionToApi 'PlutusV1 = Api.PlutusScriptV1 - PlutusVersionToApi 'PlutusV2 = Api.PlutusScriptV2 - PlutusVersionToApi 'PlutusV3 = Api.PlutusScriptV3 + PlutusVersionToApi 'PlutusV1 = Api.PlutusScriptV1 + PlutusVersionToApi 'PlutusV2 = Api.PlutusScriptV2 + PlutusVersionToApi 'PlutusV3 = Api.PlutusScriptV3 singPlutusVersionToApi :: SingPlutusVersion v -> Api.S.PlutusScriptVersion (PlutusVersionToApi v) singPlutusVersionToApi SingPlutusV1 = Api.PlutusScriptV1 @@ -87,9 +86,10 @@ type family GreaterOrEqual (v :: Ordering) :: Bool where GreaterOrEqual 'EQ = 'True GreaterOrEqual 'LT = 'False --- | Constraint that @v >= u@. --- --- If transaction is making use of V2 features (such as reference inputs) then as these cannot be represented in script context of V1 scripts, we need to ensure that the involved script version is at least V2. Likewise for other versions. +{- | Constraint that @v >= u@. + +If transaction is making use of V2 features (such as reference inputs) then as these cannot be represented in script context of V1 scripts, we need to ensure that the involved script version is at least V2. Likewise for other versions. +-} type VersionIsGreaterOrEqual (v :: PlutusVersion) (u :: PlutusVersion) = GreaterOrEqual (v `CmpPlutusVersion` u) ~ 'True -- | Constraint that @v > u@. diff --git a/src/GeniusYield/Types/ProtocolParameters.hs b/src/GeniusYield/Types/ProtocolParameters.hs index 3b003045..07907a41 100644 --- a/src/GeniusYield/Types/ProtocolParameters.hs +++ b/src/GeniusYield/Types/ProtocolParameters.hs @@ -1,9 +1,9 @@ module GeniusYield.Types.ProtocolParameters ( - ApiProtocolParameters - ) where + ApiProtocolParameters, +) where -import qualified Cardano.Api.Ledger as Api.L -import qualified Cardano.Api.Shelley as Api.S -import GeniusYield.Types.Era +import Cardano.Api.Ledger qualified as Api.L +import Cardano.Api.Shelley qualified as Api.S +import GeniusYield.Types.Era type ApiProtocolParameters = Api.L.PParams (Api.S.ShelleyLedgerEra ApiEra) diff --git a/src/GeniusYield/Types/Providers.hs b/src/GeniusYield/Types/Providers.hs index d642a5b8..71183b71 100644 --- a/src/GeniusYield/Types/Providers.hs +++ b/src/GeniusYield/Types/Providers.hs @@ -1,104 +1,116 @@ -{-| +{- | Module : GeniusYield.Types.Providers Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop -} -module GeniusYield.Types.Providers - ( -- * Lookup Datum - GYLookupDatum - -- * Submit Tx - , GYSubmitTx - -- * Await Tx Confirmed - , GYAwaitTx - , GYAwaitTxParameters (..) - , GYAwaitTxException (..) - -- * Get current slot - , GYSlotActions (..) - , gyGetSlotOfCurrentBlock - , gyWaitForNextBlock - , gyWaitForNextBlock_ - , gyWaitForNextBlockDefault - , gyWaitUntilSlot - , gyWaitUntilSlotDefault - , makeSlotActions - -- * Get network parameters - , GYGetParameters (..) - , gyGetProtocolParameters - , gyGetSystemStart - , gyGetEraHistory - , gyGetStakePools - , gyGetSlotConfig - , makeGetParameters - -- * Query UTxO - , gyQueryUtxosAtAddressWithDatumsDefault - , gyQueryUtxosAtAddressesWithDatumsDefault - , gyQueryUtxosAtPaymentCredsWithDatumsDefault - , gyQueryUtxosAtPaymentCredWithDatumsDefault - , gyQueryUtxosAtTxOutRefsWithDatumsDefault - , GYQueryUTxO (..) - , gyQueryUtxosAtAddresses - , gyQueryUtxosAtAddressWithDatums - , gyQueryUtxosAtAddressesWithDatums - , gyQueryUtxosAtPaymentCredWithDatums - , gyQueryUtxosAtPaymentCredsWithDatums - , gyQueryUtxosAtAddress - , gyQueryUtxosAtPaymentCredential - , gyQueryUtxosAtPaymentCredentials - , gyQueryUtxosAtTxOutRefs - , gyQueryUtxosAtTxOutRefsWithDatums - , gyQueryUtxoAtTxOutRef - , gyQueryUtxoRefsAtAddress - , gyQueryUtxoRefsAtAddressDefault - , gyQueryUtxoAtAddressesDefault - , gyQueryUtxoAtPaymentCredentialsDefault - , gyQueryUtxosAtTxOutRefsDefault - -- * Logging - , gyLog - , gyLogDebug - , gyLogInfo - , gyLogWarning - , gyLogError - , noLogging - , simpleLogging - -- * Providers - , GYProviders (..) - ) where - -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import Cardano.Slotting.Time (SystemStart) -import Control.AutoUpdate (UpdateSettings (..), - defaultUpdateSettings, - mkAutoUpdate) -import Control.Concurrent (threadDelay) -import Control.Concurrent.Class.MonadMVar.Strict (StrictMVar, - modifyMVar, newMVar) -import Control.Monad ((<$!>)) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Default (Default, def) -import qualified Data.Text as Txt -import Data.Time -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Word (Word64) -import GeniusYield.CardanoApi.EraHistory (getEraEndSlot) -import GeniusYield.Imports -import GeniusYield.TxBuilder.Errors -import GeniusYield.Types.Address -import GeniusYield.Types.Credential (GYPaymentCredential) -import GeniusYield.Types.Datum -import GeniusYield.Types.Logging -import GeniusYield.Types.ProtocolParameters -import GeniusYield.Types.Slot -import GeniusYield.Types.SlotConfig -import GeniusYield.Types.StakeAddressInfo (GYStakeAddressInfo) -import GeniusYield.Types.Time (timeToPOSIX) -import GeniusYield.Types.Tx -import GeniusYield.Types.TxOutRef -import GeniusYield.Types.UTxO -import GeniusYield.Types.Value (GYAssetClass) -import GHC.Stack (withFrozenCallStack) +module GeniusYield.Types.Providers ( + -- * Lookup Datum + GYLookupDatum, + + -- * Submit Tx + GYSubmitTx, + + -- * Await Tx Confirmed + GYAwaitTx, + GYAwaitTxParameters (..), + GYAwaitTxException (..), + + -- * Get current slot + GYSlotActions (..), + gyGetSlotOfCurrentBlock, + gyWaitForNextBlock, + gyWaitForNextBlock_, + gyWaitForNextBlockDefault, + gyWaitUntilSlot, + gyWaitUntilSlotDefault, + makeSlotActions, + + -- * Get network parameters + GYGetParameters (..), + gyGetProtocolParameters, + gyGetSystemStart, + gyGetEraHistory, + gyGetStakePools, + gyGetSlotConfig, + makeGetParameters, + + -- * Query UTxO + gyQueryUtxosAtAddressWithDatumsDefault, + gyQueryUtxosAtAddressesWithDatumsDefault, + gyQueryUtxosAtPaymentCredsWithDatumsDefault, + gyQueryUtxosAtPaymentCredWithDatumsDefault, + gyQueryUtxosAtTxOutRefsWithDatumsDefault, + GYQueryUTxO (..), + gyQueryUtxosAtAddresses, + gyQueryUtxosAtAddressWithDatums, + gyQueryUtxosAtAddressesWithDatums, + gyQueryUtxosAtPaymentCredWithDatums, + gyQueryUtxosAtPaymentCredsWithDatums, + gyQueryUtxosAtAddress, + gyQueryUtxosAtPaymentCredential, + gyQueryUtxosAtPaymentCredentials, + gyQueryUtxosAtTxOutRefs, + gyQueryUtxosAtTxOutRefsWithDatums, + gyQueryUtxoAtTxOutRef, + gyQueryUtxoRefsAtAddress, + gyQueryUtxoRefsAtAddressDefault, + gyQueryUtxoAtAddressesDefault, + gyQueryUtxoAtPaymentCredentialsDefault, + gyQueryUtxosAtTxOutRefsDefault, + + -- * Logging + gyLog, + gyLogDebug, + gyLogInfo, + gyLogWarning, + gyLogError, + noLogging, + simpleLogging, + + -- * Providers + GYProviders (..), +) where + +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Slotting.Time (SystemStart) +import Control.AutoUpdate ( + UpdateSettings (..), + defaultUpdateSettings, + mkAutoUpdate, + ) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Class.MonadMVar.Strict ( + StrictMVar, + modifyMVar, + newMVar, + ) +import Control.Monad ((<$!>)) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Default (Default, def) +import Data.Text qualified as Txt +import Data.Time +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Word (Word64) +import GHC.Stack (withFrozenCallStack) +import GeniusYield.CardanoApi.EraHistory (getEraEndSlot) +import GeniusYield.Imports +import GeniusYield.TxBuilder.Errors +import GeniusYield.Types.Address +import GeniusYield.Types.Credential (GYPaymentCredential) +import GeniusYield.Types.Datum +import GeniusYield.Types.Logging +import GeniusYield.Types.ProtocolParameters +import GeniusYield.Types.Slot +import GeniusYield.Types.SlotConfig +import GeniusYield.Types.StakeAddressInfo (GYStakeAddressInfo) +import GeniusYield.Types.Time (timeToPOSIX) +import GeniusYield.Types.Tx +import GeniusYield.Types.TxOutRef +import GeniusYield.Types.UTxO +import GeniusYield.Types.Value (GYAssetClass) {- Note [Caching and concurrently accessible MVars] @@ -131,16 +143,16 @@ There is no (safe)way to perform IO within an 'atomically' block. So STM doesn't ------------------------------------------------------------------------------- data GYProviders = GYProviders - { gyLookupDatum :: !GYLookupDatum - , gySubmitTx :: !GYSubmitTx - , gyAwaitTxConfirmed :: !GYAwaitTx - -- ^ This is a function to see whether the submitted transaction is successfully seen on chain. __NOTE:__ Don't call `gyAwaitTxConfirmed` on transaction that has been submitted long ago as we determine presence of submitted transaction by looking for any UTxO generated by it. Though we maintain information for even spent UTxOs until the block which spent them is sufficiently deep (2160 blocks for mainnet). - , gySlotActions :: !GYSlotActions - , gyGetParameters :: !GYGetParameters - , gyQueryUTxO :: !GYQueryUTxO - , gyGetStakeAddressInfo :: !(GYStakeAddress -> IO (Maybe GYStakeAddressInfo)) - , gyLog' :: !GYLogConfiguration - } + { gyLookupDatum :: !GYLookupDatum + , gySubmitTx :: !GYSubmitTx + , gyAwaitTxConfirmed :: !GYAwaitTx + -- ^ This is a function to see whether the submitted transaction is successfully seen on chain. __NOTE:__ Don't call `gyAwaitTxConfirmed` on transaction that has been submitted long ago as we determine presence of submitted transaction by looking for any UTxO generated by it. Though we maintain information for even spent UTxOs until the block which spent them is sufficiently deep (2160 blocks for mainnet). + , gySlotActions :: !GYSlotActions + , gyGetParameters :: !GYGetParameters + , gyQueryUTxO :: !GYQueryUTxO + , gyGetStakeAddressInfo :: !(GYStakeAddress -> IO (Maybe GYStakeAddressInfo)) + , gyLog' :: !GYLogConfiguration + } gyGetSlotOfCurrentBlock :: GYProviders -> IO GYSlot gyGetSlotOfCurrentBlock = gyGetSlotOfCurrentBlock' . gySlotActions @@ -152,45 +164,44 @@ gyWaitUntilSlot :: GYProviders -> GYSlot -> IO GYSlot gyWaitUntilSlot providers = gyWaitUntilSlot' (gySlotActions providers) -- | 'gyWaitForNextBlock' variant which doesn't return current slot. --- gyWaitForNextBlock_ :: GYProviders -> IO () gyWaitForNextBlock_ = void . gyWaitForNextBlock gyQueryUtxosAtAddress :: GYProviders -> GYAddress -> Maybe GYAssetClass -> IO GYUTxOs gyQueryUtxosAtAddress = gyQueryUtxosAtAddress' . gyQueryUTxO -gyQueryUtxosAtAddresses :: GYProviders -> [GYAddress] -> IO GYUTxOs +gyQueryUtxosAtAddresses :: GYProviders -> [GYAddress] -> IO GYUTxOs gyQueryUtxosAtAddresses = gyQueryUtxosAtAddresses' . gyQueryUTxO gyQueryUtxosAtPaymentCredential :: GYProviders -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs gyQueryUtxosAtPaymentCredential = gyQueryUtxosAtPaymentCredential' . gyQueryUTxO -gyQueryUtxosAtPaymentCredentials :: GYProviders -> [GYPaymentCredential] -> IO GYUTxOs +gyQueryUtxosAtPaymentCredentials :: GYProviders -> [GYPaymentCredential] -> IO GYUTxOs gyQueryUtxosAtPaymentCredentials = gyQueryUtxosAtPaymentCredentials' . gyQueryUTxO gyQueryUtxosAtAddressWithDatums :: GYProviders -> GYAddress -> Maybe GYAssetClass -> IO [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtAddressWithDatums provider addr mAssetClass = case gyQueryUtxosAtAddressWithDatums' $ gyQueryUTxO provider of Nothing -> gyQueryUtxosAtAddressWithDatumsDefault (gyQueryUtxosAtAddress provider) (gyLookupDatum provider) addr mAssetClass - Just f -> f addr mAssetClass + Just f -> f addr mAssetClass gyQueryUtxosAtAddressesWithDatums :: GYProviders -> [GYAddress] -> IO [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtAddressesWithDatums provider addrs = case gyQueryUtxosAtAddressesWithDatums' $ gyQueryUTxO provider of Nothing -> gyQueryUtxosAtAddressesWithDatumsDefault (gyQueryUtxosAtAddresses provider) (gyLookupDatum provider) addrs - Just f -> f addrs + Just f -> f addrs gyQueryUtxosAtPaymentCredWithDatums :: GYProviders -> GYPaymentCredential -> Maybe GYAssetClass -> IO [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtPaymentCredWithDatums provider cred mAssetClass = case gyQueryUtxosAtPaymentCredWithDatums' $ gyQueryUTxO provider of Nothing -> gyQueryUtxosAtPaymentCredWithDatumsDefault (gyQueryUtxosAtPaymentCredential provider) (gyLookupDatum provider) cred mAssetClass - Just f -> f cred mAssetClass + Just f -> f cred mAssetClass gyQueryUtxosAtPaymentCredsWithDatums :: GYProviders -> [GYPaymentCredential] -> IO [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtPaymentCredsWithDatums provider pcs = case gyQueryUtxosAtPaymentCredsWithDatums' $ gyQueryUTxO provider of Nothing -> gyQueryUtxosAtPaymentCredsWithDatumsDefault (gyQueryUtxosAtPaymentCredentials provider) (gyLookupDatum provider) pcs - Just f -> f pcs + Just f -> f pcs gyQueryUtxosAtTxOutRefs :: GYProviders -> [GYTxOutRef] -> IO GYUTxOs gyQueryUtxosAtTxOutRefs = gyQueryUtxosAtTxOutRefs' . gyQueryUTxO @@ -199,7 +210,7 @@ gyQueryUtxosAtTxOutRefsWithDatums :: GYProviders -> [GYTxOutRef] -> IO [(GYUTxO, gyQueryUtxosAtTxOutRefsWithDatums provider refs = case gyQueryUtxosAtTxOutRefsWithDatums' $ gyQueryUTxO provider of Nothing -> gyQueryUtxosAtTxOutRefsWithDatumsDefault (gyQueryUtxosAtTxOutRefs provider) (gyLookupDatum provider) refs - Just f -> f refs + Just f -> f refs gyQueryUtxoAtTxOutRef :: GYProviders -> GYTxOutRef -> IO (Maybe GYUTxO) gyQueryUtxoAtTxOutRef = gyQueryUtxoAtTxOutRef' . gyQueryUTxO @@ -245,28 +256,29 @@ type GYAwaitTx = GYAwaitTxParameters -> GYTxId -> IO () -- | Await transaction parameters. data GYAwaitTxParameters = GYAwaitTxParameters - { maxAttempts :: !Int - -- ^ Max number of attempts before give up. - , checkInterval :: !Int - -- ^ Wait time for each attempt (in microseconds). - , confirmations :: !Word64 - -- ^ Min number of block confirmation. __NOTE:__ We might wait for more blocks than what is mentioned here but certainly not less. - } - deriving stock (Show) + { maxAttempts :: !Int + -- ^ Max number of attempts before give up. + , checkInterval :: !Int + -- ^ Wait time for each attempt (in microseconds). + , confirmations :: !Word64 + -- ^ Min number of block confirmation. __NOTE:__ We might wait for more blocks than what is mentioned here but certainly not less. + } + deriving stock (Show) instance Default GYAwaitTxParameters where - def = GYAwaitTxParameters - { maxAttempts = 10 - , checkInterval = 3_000_000 - , confirmations = 1 - } + def = + GYAwaitTxParameters + { maxAttempts = 10 + , checkInterval = 3_000_000 + , confirmations = 1 + } newtype GYAwaitTxException = GYAwaitTxException GYAwaitTxParameters - deriving anyclass (Exception) + deriving anyclass (Exception) instance Show GYAwaitTxException where - show (GYAwaitTxException awaitTxParams) = - "Tries exceeded, given maximum: " ++ show awaitTxParams + show (GYAwaitTxException awaitTxParams) = + "Tries exceeded, given maximum: " ++ show awaitTxParams ------------------------------------------------------------------------------- -- Current slot @@ -274,41 +286,43 @@ instance Show GYAwaitTxException where -- | How to get current slot? data GYSlotActions = GYSlotActions - { gyGetSlotOfCurrentBlock' :: !(IO GYSlot) - , gyWaitForNextBlock' :: !(IO GYSlot) - , gyWaitUntilSlot' :: !(GYSlot -> IO GYSlot) - } + { gyGetSlotOfCurrentBlock' :: !(IO GYSlot) + , gyWaitForNextBlock' :: !(IO GYSlot) + , gyWaitUntilSlot' :: !(GYSlot -> IO GYSlot) + } --- | Wait for the next block. --- --- 'threadDelay' until current slot getter returns another value. +{- | Wait for the next block. + +'threadDelay' until current slot getter returns another value. +-} gyWaitForNextBlockDefault :: IO GYSlot -> IO GYSlot gyWaitForNextBlockDefault getSlotOfCurrentBlock = do - s <- getSlotOfCurrentBlock - go s + s <- getSlotOfCurrentBlock + go s where go :: GYSlot -> IO GYSlot go s = do - threadDelay 100_000 - t <- getSlotOfCurrentBlock - if t > s - then return t - else go s - --- | Wait until slot. --- --- Returns the new current slot, which might be larger. + threadDelay 100_000 + t <- getSlotOfCurrentBlock + if t > s + then return t + else go s + +{- | Wait until slot. + +Returns the new current slot, which might be larger. +-} gyWaitUntilSlotDefault :: IO GYSlot -> GYSlot -> IO GYSlot gyWaitUntilSlotDefault getSlotOfCurrentBlock s = loop where loop :: IO GYSlot loop = do - t <- getSlotOfCurrentBlock - if t >= s - then return t - else do - threadDelay 100_000 - loop + t <- getSlotOfCurrentBlock + if t >= s + then return t + else do + threadDelay 100_000 + loop -- | Contains the data, alongside the time after which it should be refetched. data GYSlotStore = GYSlotStore !UTCTime !GYSlot @@ -318,36 +332,39 @@ a given duration of time has passed. This uses IO to set up some mutable references used for caching. -} -makeSlotActions :: NominalDiffTime - -- ^ The time to cache current slots for. - -> IO GYSlot - -- ^ Getting current slot directly from the provider - -> IO GYSlotActions +makeSlotActions :: + -- | The time to cache current slots for. + NominalDiffTime -> + -- | Getting current slot directly from the provider + IO GYSlot -> + IO GYSlotActions makeSlotActions t getSlotOfCurrentBlock = do - getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime} - slotRefetchTime <- addUTCTime t <$> getTime - initSlot <- getSlotOfCurrentBlock - slotStoreRef <- newMVar $ GYSlotStore slotRefetchTime initSlot - let gcs = getSlotOfCurrentBlock' getTime slotStoreRef - pure GYSlotActions - { gyGetSlotOfCurrentBlock' = gcs - , gyWaitForNextBlock' = gyWaitForNextBlockDefault gcs - , gyWaitUntilSlot' = gyWaitUntilSlotDefault gcs - } + getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime} + slotRefetchTime <- addUTCTime t <$> getTime + initSlot <- getSlotOfCurrentBlock + slotStoreRef <- newMVar $ GYSlotStore slotRefetchTime initSlot + let gcs = getSlotOfCurrentBlock' getTime slotStoreRef + pure + GYSlotActions + { gyGetSlotOfCurrentBlock' = gcs + , gyWaitForNextBlock' = gyWaitForNextBlockDefault gcs + , gyWaitUntilSlot' = gyWaitUntilSlotDefault gcs + } where getSlotOfCurrentBlock' :: IO UTCTime -> StrictMVar IO GYSlotStore -> IO GYSlot getSlotOfCurrentBlock' getTime var = do - -- See note: [Caching and concurrently accessible MVars]. - modifyMVar var $ \(GYSlotStore slotRefetchTime slotData) -> do - now <- getTime - if now < slotRefetchTime then do - -- Return unmodified. - pure (GYSlotStore slotRefetchTime slotData, slotData) - else do - newSlot <- getSlotOfCurrentBlock - newNow <- getTime - let newSlotRefetchTime = addUTCTime t newNow - pure (GYSlotStore newSlotRefetchTime newSlot, newSlot) + -- See note: [Caching and concurrently accessible MVars]. + modifyMVar var $ \(GYSlotStore slotRefetchTime slotData) -> do + now <- getTime + if now < slotRefetchTime + then do + -- Return unmodified. + pure (GYSlotStore slotRefetchTime slotData, slotData) + else do + newSlot <- getSlotOfCurrentBlock + newNow <- getTime + let newSlotRefetchTime = addUTCTime t newNow + pure (GYSlotStore newSlotRefetchTime newSlot, newSlot) ------------------------------------------------------------------------------- -- Protocol parameters @@ -355,12 +372,12 @@ makeSlotActions t getSlotOfCurrentBlock = do -- | How to get protocol parameters? ... and other data to do balancing. data GYGetParameters = GYGetParameters - { gyGetProtocolParameters' :: !(IO ApiProtocolParameters) - , gyGetSystemStart' :: !(IO SystemStart) - , gyGetEraHistory' :: !(IO Api.EraHistory) - , gyGetStakePools' :: !(IO (Set Api.S.PoolId)) - , gyGetSlotConfig' :: !(IO GYSlotConfig) - } + { gyGetProtocolParameters' :: !(IO ApiProtocolParameters) + , gyGetSystemStart' :: !(IO SystemStart) + , gyGetEraHistory' :: !(IO Api.EraHistory) + , gyGetStakePools' :: !(IO (Set Api.S.PoolId)) + , gyGetSlotConfig' :: !(IO GYSlotConfig) + } -- | Contains the data, optionally alongside the time after which it should be refetched. data GYParameterStore a = GYParameterStore !(Maybe UTCTime) !a @@ -369,61 +386,64 @@ data GYParameterStore a = GYParameterStore !(Maybe UTCTime) !a This uses IO to set up some mutable references used for caching. -} -makeGetParameters - :: IO ApiProtocolParameters - -- ^ Getting protocol parameters - -> IO SystemStart - -- ^ Getting system start - -> IO Api.EraHistory - -- ^ Getting era history - -> IO (Set Api.S.PoolId) - -- ^ Getting stake pools - -> IO GYGetParameters +makeGetParameters :: + -- | Getting protocol parameters + IO ApiProtocolParameters -> + -- | Getting system start + IO SystemStart -> + -- | Getting era history + IO Api.EraHistory -> + -- | Getting stake pools + IO (Set Api.S.PoolId) -> + IO GYGetParameters makeGetParameters getProtParams getSysStart getEraHist getStkPools = do - getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime} - sysStart <- getSysStart - let getSlotConf = makeSlotConfigIO sysStart - initProtParams <- getProtParams - initEraHist <- getEraHist - initStkPools <- getStkPools - initSlotConf <- getSlotConf initEraHist - - let slotEndToUTCTime slotConf = posixSecondsToUTCTime . timeToPOSIX . slotToBeginTimePure slotConf . flip unsafeAdvanceSlot 1 . slotFromApi - buildParam :: a -> GYParameterStore a - buildParam = GYParameterStore (slotEndToUTCTime initSlotConf <$!> getEraEndSlot initEraHist) - getProtParams' = newMVar (buildParam initProtParams) >>= mkMethod (const getProtParams) - getEraHist' = newMVar (buildParam initEraHist) >>= mkMethod pure - getStkPools' = newMVar (buildParam initStkPools) >>= mkMethod (const getStkPools) - getSlotConf' = newMVar (buildParam initSlotConf) >>= mkMethod getSlotConf - {- | Make an efficient 'GYGetParameters' method. - This will only refresh the data (using the provided 'dataRefreshF') if current time has passed the - era end. It will also update the 'eraEndTime' to the new era end when necessary. - - If refreshing is not necessary, the data is simply returned from the storage. - -} - mkMethod :: (Api.EraHistory -> IO a) -> StrictMVar IO (GYParameterStore a) -> IO a - mkMethod dataRefreshF dataRef = do - -- See note: [Caching and concurrently accessible MVars]. - modifyMVar dataRef $ \(GYParameterStore eraEndTime a) -> do - currTime <- getTime - if beforeEnd currTime eraEndTime then - pure (GYParameterStore eraEndTime a, a) - else do - newEraHist <- getEraHist - newSlotConf <- getSlotConf newEraHist -- Remember that this is actually a pure computation being lifted to IO here. - newData <- dataRefreshF newEraHist - pure (GYParameterStore (slotEndToUTCTime newSlotConf <$> getEraEndSlot newEraHist) newData, newData) - pure $ GYGetParameters - { gyGetSystemStart' = pure sysStart - , gyGetProtocolParameters' = getProtParams' - , gyGetEraHistory' = getEraHist' - , gyGetStakePools' = getStkPools' - , gyGetSlotConfig' = getSlotConf' - } + getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime} + sysStart <- getSysStart + let getSlotConf = makeSlotConfigIO sysStart + initProtParams <- getProtParams + initEraHist <- getEraHist + initStkPools <- getStkPools + initSlotConf <- getSlotConf initEraHist + + let slotEndToUTCTime slotConf = posixSecondsToUTCTime . timeToPOSIX . slotToBeginTimePure slotConf . flip unsafeAdvanceSlot 1 . slotFromApi + buildParam :: a -> GYParameterStore a + buildParam = GYParameterStore (slotEndToUTCTime initSlotConf <$!> getEraEndSlot initEraHist) + getProtParams' = newMVar (buildParam initProtParams) >>= mkMethod (const getProtParams) + getEraHist' = newMVar (buildParam initEraHist) >>= mkMethod pure + getStkPools' = newMVar (buildParam initStkPools) >>= mkMethod (const getStkPools) + getSlotConf' = newMVar (buildParam initSlotConf) >>= mkMethod getSlotConf + -- \| Make an efficient 'GYGetParameters' method. + -- This will only refresh the data (using the provided 'dataRefreshF') if current time has passed the + -- era end. It will also update the 'eraEndTime' to the new era end when necessary. + -- + -- If refreshing is not necessary, the data is simply returned from the storage. + -- + mkMethod :: (Api.EraHistory -> IO a) -> StrictMVar IO (GYParameterStore a) -> IO a + mkMethod dataRefreshF dataRef = do + -- See note: [Caching and concurrently accessible MVars]. + modifyMVar dataRef $ \(GYParameterStore eraEndTime a) -> do + currTime <- getTime + if beforeEnd currTime eraEndTime + then + pure (GYParameterStore eraEndTime a, a) + else do + newEraHist <- getEraHist + newSlotConf <- getSlotConf newEraHist -- Remember that this is actually a pure computation being lifted to IO here. + newData <- dataRefreshF newEraHist + pure (GYParameterStore (slotEndToUTCTime newSlotConf <$> getEraEndSlot newEraHist) newData, newData) + pure $ + GYGetParameters + { gyGetSystemStart' = pure sysStart + , gyGetProtocolParameters' = getProtParams' + , gyGetEraHistory' = getEraHist' + , gyGetStakePools' = getStkPools' + , gyGetSlotConfig' = getSlotConf' + } where - beforeEnd _ Nothing = True + beforeEnd _ Nothing = True beforeEnd currTime (Just endTime) = currTime < endTime - makeSlotConfigIO sysStart = either + makeSlotConfigIO sysStart = + either (throwIO . GYConversionException . GYEraSummariesToSlotConfigError . Txt.pack) pure . makeSlotConfig sysStart @@ -434,24 +454,24 @@ makeGetParameters getProtParams getSysStart getEraHist getStkPools = do -- | How to query utxos? data GYQueryUTxO = GYQueryUTxO - { gyQueryUtxosAtTxOutRefs' :: !([GYTxOutRef] -> IO GYUTxOs) - , gyQueryUtxosAtTxOutRefsWithDatums' :: !(Maybe ([GYTxOutRef] -> IO [(GYUTxO, Maybe GYDatum)])) - -- ^ `gyQueryUtxosAtTxOutRefsWithDatums'` is as `Maybe` so that if an implementation is not given, a default one is used. - , gyQueryUtxoAtTxOutRef' :: !(GYTxOutRef -> IO (Maybe GYUTxO)) - , gyQueryUtxoRefsAtAddress' :: !(GYAddress -> IO [GYTxOutRef]) - , gyQueryUtxosAtAddress' :: !(GYAddress -> Maybe GYAssetClass -> IO GYUTxOs) - , gyQueryUtxosAtAddressWithDatums' :: !(Maybe (GYAddress -> Maybe GYAssetClass -> IO [(GYUTxO, Maybe GYDatum)])) - , gyQueryUtxosAtAddresses' :: !([GYAddress] -> IO GYUTxOs) - , gyQueryUtxosAtAddressesWithDatums' :: !(Maybe ([GYAddress] -> IO [(GYUTxO, Maybe GYDatum)])) - -- ^ `gyQueryUtxosAtAddressesWithDatums'` is as `Maybe` so that if an implementation is not given, a default one is used. - , gyQueryUtxosAtPaymentCredential' :: !(GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs) - , gyQueryUtxosAtPaymentCredWithDatums' :: !(Maybe (GYPaymentCredential -> Maybe GYAssetClass -> IO [(GYUTxO, Maybe GYDatum)])) - -- ^ `gyQueryUtxosAtPaymentCredWithDatums'` is as `Maybe` so that if an implementation is not given, a default one is used. - , gyQueryUtxosAtPaymentCredentials' :: !([GYPaymentCredential] -> IO GYUTxOs) - , gyQueryUtxosAtPaymentCredsWithDatums' - :: !(Maybe ([GYPaymentCredential] -> IO [(GYUTxO, Maybe GYDatum)])) - -- ^ `gyQueryUtxosAtPaymentCredsWithDatums'` is as `Maybe` so that if an implementation is not given, a default one is used. - } + { gyQueryUtxosAtTxOutRefs' :: !([GYTxOutRef] -> IO GYUTxOs) + , gyQueryUtxosAtTxOutRefsWithDatums' :: !(Maybe ([GYTxOutRef] -> IO [(GYUTxO, Maybe GYDatum)])) + -- ^ `gyQueryUtxosAtTxOutRefsWithDatums'` is as `Maybe` so that if an implementation is not given, a default one is used. + , gyQueryUtxoAtTxOutRef' :: !(GYTxOutRef -> IO (Maybe GYUTxO)) + , gyQueryUtxoRefsAtAddress' :: !(GYAddress -> IO [GYTxOutRef]) + , gyQueryUtxosAtAddress' :: !(GYAddress -> Maybe GYAssetClass -> IO GYUTxOs) + , gyQueryUtxosAtAddressWithDatums' :: !(Maybe (GYAddress -> Maybe GYAssetClass -> IO [(GYUTxO, Maybe GYDatum)])) + , gyQueryUtxosAtAddresses' :: !([GYAddress] -> IO GYUTxOs) + , gyQueryUtxosAtAddressesWithDatums' :: !(Maybe ([GYAddress] -> IO [(GYUTxO, Maybe GYDatum)])) + -- ^ `gyQueryUtxosAtAddressesWithDatums'` is as `Maybe` so that if an implementation is not given, a default one is used. + , gyQueryUtxosAtPaymentCredential' :: !(GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs) + , gyQueryUtxosAtPaymentCredWithDatums' :: !(Maybe (GYPaymentCredential -> Maybe GYAssetClass -> IO [(GYUTxO, Maybe GYDatum)])) + -- ^ `gyQueryUtxosAtPaymentCredWithDatums'` is as `Maybe` so that if an implementation is not given, a default one is used. + , gyQueryUtxosAtPaymentCredentials' :: !([GYPaymentCredential] -> IO GYUTxOs) + , gyQueryUtxosAtPaymentCredsWithDatums' :: + !(Maybe ([GYPaymentCredential] -> IO [(GYUTxO, Maybe GYDatum)])) + -- ^ `gyQueryUtxosAtPaymentCredsWithDatums'` is as `Maybe` so that if an implementation is not given, a default one is used. + } -- | Query Utxo Refs at address (default implementation) gyQueryUtxoRefsAtAddressDefault :: (GYAddress -> Maybe GYAssetClass -> IO GYUTxOs) -> GYAddress -> IO [GYTxOutRef] @@ -476,48 +496,48 @@ gyQueryUtxosAtTxOutRefsDefault queryUtxoAtTxOutRef orefs = do pure $ utxosFromList $ catMaybes utxos -- | Lookup UTxOs at given 'GYAddress' with their datums. This is a default implementation using `utxosAtAddress` and `lookupDatum`. -gyQueryUtxosAtAddressWithDatumsDefault :: Monad m => (GYAddress -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYAddress -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtAddressWithDatumsDefault :: (Monad m) => (GYAddress -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYAddress -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtAddressWithDatumsDefault utxosAtAddressFun lookupDatumFun addr mAssetClass = do utxosWithoutDatumResolutions <- utxosAtAddressFun addr mAssetClass utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Lookup UTxOs at zero or more 'GYAddress' with their datums. This is a default implementation using `utxosAtAddresses` and `lookupDatum`. -gyQueryUtxosAtAddressesWithDatumsDefault :: Monad m => ([GYAddress] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYAddress] -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtAddressesWithDatumsDefault :: (Monad m) => ([GYAddress] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYAddress] -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtAddressesWithDatumsDefault utxosAtAddressesFun lookupDatumFun addrs = do utxosWithoutDatumResolutions <- utxosAtAddressesFun addrs utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Lookup UTxOs at zero or more 'GYPaymentCredential' with their datums. This is a default implementation using `utxosAtPaymentCredentials` and `lookupDatum`. -gyQueryUtxosAtPaymentCredsWithDatumsDefault :: Monad m => ([GYPaymentCredential] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtPaymentCredsWithDatumsDefault :: (Monad m) => ([GYPaymentCredential] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtPaymentCredsWithDatumsDefault utxosAtPaymentCredsFun lookupDatumFun pcs = do utxosWithoutDatumResolutions <- utxosAtPaymentCredsFun pcs utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Lookup UTxOs at given 'GYPaymentCredential' with their datums. This is a default implementation using `utxosAtPaymentCredential` and `lookupDatum`. -gyQueryUtxosAtPaymentCredWithDatumsDefault :: Monad m => (GYPaymentCredential -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYPaymentCredential -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtPaymentCredWithDatumsDefault :: (Monad m) => (GYPaymentCredential -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYPaymentCredential -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtPaymentCredWithDatumsDefault utxosAtPaymentCredFun lookupDatumFun cred mAssetClass = do utxosWithoutDatumResolutions <- utxosAtPaymentCredFun cred mAssetClass utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Append UTxO information with their fetched datum. -utxosDatumResolver :: Monad m => GYUTxOs -> (GYDatumHash -> m (Maybe GYDatum)) -> m [(GYUTxO, Maybe GYDatum)] +utxosDatumResolver :: (Monad m) => GYUTxOs -> (GYDatumHash -> m (Maybe GYDatum)) -> m [(GYUTxO, Maybe GYDatum)] utxosDatumResolver utxos lookupDatumFun = do let utxosWithoutDatumResolutions = utxosToList utxos forM utxosWithoutDatumResolutions $ \utxo -> do case utxoOutDatum utxo of - GYOutDatumNone -> return (utxo, Nothing) + GYOutDatumNone -> return (utxo, Nothing) GYOutDatumInline d -> return (utxo, Just d) - GYOutDatumHash h -> (utxo, ) <$> lookupDatumFun h + GYOutDatumHash h -> (utxo,) <$> lookupDatumFun h -- | Lookup UTxOs at zero or more 'GYTxOutRef' with their datums. This is a default implementation using `utxosAtTxOutRefs` and `lookupDatum`. -gyQueryUtxosAtTxOutRefsWithDatumsDefault :: Monad m => ([GYTxOutRef] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYTxOutRef] -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtTxOutRefsWithDatumsDefault :: (Monad m) => ([GYTxOutRef] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYTxOutRef] -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtTxOutRefsWithDatumsDefault utxosAtTxOutRefsFun lookupDatumFun refs = do utxosWithoutDatumResolutions <- utxosToList <$> utxosAtTxOutRefsFun refs forM utxosWithoutDatumResolutions $ \utxo -> do case utxoOutDatum utxo of - GYOutDatumNone -> return (utxo, Nothing) + GYOutDatumNone -> return (utxo, Nothing) GYOutDatumInline d -> return (utxo, Just d) - GYOutDatumHash h -> (utxo, ) <$> lookupDatumFun h + GYOutDatumHash h -> (utxo,) <$> lookupDatumFun h ------------------------------------------------------------------------------- -- Logging @@ -527,20 +547,20 @@ gyLog :: (HasCallStack, MonadIO m) => GYProviders -> GYLogNamespace -> GYLogSeve gyLog providers ns s msg = let cfg = gyLog' providers cfg' = cfgAddNamespace ns cfg - in withFrozenCallStack $ liftIO $ logRun cfg' s msg + in withFrozenCallStack $ liftIO $ logRun cfg' s msg gyLogDebug, gyLogInfo, gyLogWarning, gyLogError :: (HasCallStack, MonadIO m) => GYProviders -> GYLogNamespace -> String -> m () -gyLogDebug p ns = withFrozenCallStack $ gyLog p ns GYDebug -gyLogInfo p ns = withFrozenCallStack $ gyLog p ns GYInfo +gyLogDebug p ns = withFrozenCallStack $ gyLog p ns GYDebug +gyLogInfo p ns = withFrozenCallStack $ gyLog p ns GYInfo gyLogWarning p ns = withFrozenCallStack $ gyLog p ns GYWarning -gyLogError p ns = withFrozenCallStack $ gyLog p ns GYError +gyLogError p ns = withFrozenCallStack $ gyLog p ns GYError noLogging :: GYLogConfiguration noLogging = GYLogConfiguration { cfgLogContexts = mempty , cfgLogNamespace = mempty - , cfgLogDirector = Right $ GYRawLog { rawLogRun = unitRawLogger, rawLogCleanUp = pure () } + , cfgLogDirector = Right $ GYRawLog {rawLogRun = unitRawLogger, rawLogCleanUp = pure ()} } -- | Logging messages using the given severity filter with given IO action. @@ -549,5 +569,5 @@ simpleLogging targetSev f = GYLogConfiguration { cfgLogContexts = mempty , cfgLogNamespace = mempty - , cfgLogDirector = Right $ GYRawLog { rawLogRun = simpleRawLogger targetSev f, rawLogCleanUp = pure () } + , cfgLogDirector = Right $ GYRawLog {rawLogRun = simpleRawLogger targetSev f, rawLogCleanUp = pure ()} } diff --git a/src/GeniusYield/Types/PubKeyHash.hs b/src/GeniusYield/Types/PubKeyHash.hs index 9c9168a4..19eb40f0 100644 --- a/src/GeniusYield/Types/PubKeyHash.hs +++ b/src/GeniusYield/Types/PubKeyHash.hs @@ -1,59 +1,59 @@ -{-| +{- | Module : GeniusYield.Types.PubKeyHash Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.PubKeyHash ( - GYPubKeyHash (..), - AsPubKeyHash (..), - CanSignTx, - pubKeyHashFromPlutus, - pubKeyHashToPlutus, - pubKeyHashToApi, - pubKeyHashFromApi, - pubKeyHashToLedger, - pubKeyHashFromLedger, + GYPubKeyHash (..), + AsPubKeyHash (..), + CanSignTx, + pubKeyHashFromPlutus, + pubKeyHashToPlutus, + pubKeyHashToApi, + pubKeyHashFromApi, + pubKeyHashToLedger, + pubKeyHashFromLedger, ) where -import Control.Lens ((?~)) -import GeniusYield.Imports - -import qualified Cardano.Api as Api -import qualified Cardano.Api.Ledger as Ledger -import qualified Cardano.Api.Shelley as Api -import qualified Cardano.Ledger.Keys as Ledger -import qualified Data.Aeson.Types as Aeson -import qualified Data.Csv as Csv -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import GeniusYield.Types.Ledger -import qualified PlutusLedgerApi.V1.Crypto as Plutus -import qualified PlutusTx.Builtins as Plutus -import qualified PlutusTx.Builtins.Internal as Plutus -import qualified Text.Printf as Printf - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import qualified Data.Csv as Csv --- >>> import qualified Text.Printf as Printf +import Control.Lens ((?~)) +import GeniusYield.Imports + +import Cardano.Api qualified as Api +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api +import Cardano.Ledger.Keys qualified as Ledger +import Data.Aeson.Types qualified as Aeson +import Data.Csv qualified as Csv +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import GeniusYield.Types.Ledger +import PlutusLedgerApi.V1.Crypto qualified as Plutus +import PlutusTx.Builtins qualified as Plutus +import PlutusTx.Builtins.Internal qualified as Plutus +import Text.Printf qualified as Printf + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import qualified Data.Csv as Csv +>>> import qualified Text.Printf as Printf +-} newtype GYPubKeyHash = GYPubKeyHash (Api.Hash Api.PaymentKey) - deriving stock Show - deriving newtype (Eq, Ord, IsString) + deriving stock (Show) + deriving newtype (Eq, Ord, IsString) class AsPubKeyHash a where toPubKeyHash :: a -> GYPubKeyHash fromPubKeyHash :: GYPubKeyHash -> a -class AsPubKeyHash a => CanSignTx a +class (AsPubKeyHash a) => CanSignTx a instance AsPubKeyHash GYPubKeyHash where toPubKeyHash = id @@ -61,47 +61,48 @@ instance AsPubKeyHash GYPubKeyHash where instance CanSignTx GYPubKeyHash --- | --- --- >>> pubKeyHashFromPlutus "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- Right (GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") --- --- >>> pubKeyHashFromPlutus "abcd" --- Left (DeserialiseRawBytesError {ptceTag = "pubKeyHashFromPlutus \"\\171\\205\", error: SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise Hash PaymentKey\"}"}) --- +{- | + +>>> pubKeyHashFromPlutus "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +Right (GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") + +>>> pubKeyHashFromPlutus "abcd" +Left (DeserialiseRawBytesError {ptceTag = "pubKeyHashFromPlutus \"\\171\\205\", error: SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise Hash PaymentKey\"}"}) +-} pubKeyHashFromPlutus :: Plutus.PubKeyHash -> Either PlutusToCardanoError GYPubKeyHash pubKeyHashFromPlutus (Plutus.PubKeyHash (Plutus.BuiltinByteString h)) = - bimap - (\e -> DeserialiseRawBytesError $ Text.pack $ "pubKeyHashFromPlutus " ++ show h ++ ", error: " ++ show e) - GYPubKeyHash + bimap + (\e -> DeserialiseRawBytesError $ Text.pack $ "pubKeyHashFromPlutus " ++ show h ++ ", error: " ++ show e) + GYPubKeyHash $ Api.deserialiseFromRawBytes (Api.AsHash Api.AsPaymentKey) h --- | --- --- >>> let Just pkh = Aeson.decode @GYPubKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" --- >>> pubKeyHashToPlutus pkh --- e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d --- +{- | + +>>> let Just pkh = Aeson.decode @GYPubKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" +>>> pubKeyHashToPlutus pkh +e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d +-} pubKeyHashToPlutus :: GYPubKeyHash -> Plutus.PubKeyHash -pubKeyHashToPlutus = coerce fromCardanoPaymentKeyHash where +pubKeyHashToPlutus = coerce fromCardanoPaymentKeyHash + where -- this is not exported from plutus-ledger fromCardanoPaymentKeyHash :: Api.Hash Api.PaymentKey -> Plutus.PubKeyHash fromCardanoPaymentKeyHash paymentKeyHash = Plutus.PubKeyHash $ Plutus.toBuiltin $ Api.serialiseToRawBytes paymentKeyHash --- | --- --- >>> let Just pkh = Aeson.decode @GYPubKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" --- >>> pubKeyHashToApi pkh --- "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- +{- | + +>>> let Just pkh = Aeson.decode @GYPubKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" +>>> pubKeyHashToApi pkh +"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +-} pubKeyHashToApi :: GYPubKeyHash -> Api.Hash Api.PaymentKey pubKeyHashToApi = coerce --- | --- --- >>> pubKeyHashFromApi "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- +{- | + +>>> pubKeyHashFromApi "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +-} pubKeyHashFromApi :: Api.Hash Api.PaymentKey -> GYPubKeyHash pubKeyHashFromApi = coerce @@ -113,70 +114,79 @@ pubKeyHashToLedger = pubKeyHashToApi >>> Api.unPaymentKeyHash >>> Ledger.coerceK pubKeyHashFromLedger :: Ledger.KeyHash (a :: Ledger.KeyRole) Ledger.StandardCrypto -> GYPubKeyHash pubKeyHashFromLedger = Ledger.coerceKeyRole >>> Api.PaymentKeyHash >>> pubKeyHashFromApi --- | --- --- >>> let Just pkh = Aeson.decode @GYPubKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" --- >>> LBS8.putStrLn $ Aeson.encode pkh --- "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- +{- | + +>>> let Just pkh = Aeson.decode @GYPubKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" +>>> LBS8.putStrLn $ Aeson.encode pkh +"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +-} instance Aeson.ToJSON GYPubKeyHash where - toJSON = Aeson.toJSON . Api.serialiseToRawBytesHexText . pubKeyHashToApi - --- | --- --- >>> Aeson.eitherDecode @GYPubKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" --- Right (GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") --- --- Invalid characters: --- --- >>> Aeson.eitherDecode @GYPubKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6azzz\"" --- Left "Error in $: RawBytesHexErrorBase16DecodeFail \"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6azzz\" \"invalid character at offset: 53\"" --- + toJSON = Aeson.toJSON . Api.serialiseToRawBytesHexText . pubKeyHashToApi + +{- | + +>>> Aeson.eitherDecode @GYPubKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d\"" +Right (GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") + +Invalid characters: + +>>> Aeson.eitherDecode @GYPubKeyHash "\"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6azzz\"" +Left "Error in $: RawBytesHexErrorBase16DecodeFail \"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6azzz\" \"invalid character at offset: 53\"" +-} instance Aeson.FromJSON GYPubKeyHash where - parseJSON = Aeson.withText "GYPubKeyHash" $ - either - (fail . show) - (return . GYPubKeyHash) + parseJSON = + Aeson.withText "GYPubKeyHash" $ + either + (fail . show) + (return . GYPubKeyHash) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsPaymentKey) . Text.encodeUtf8 --- | --- --- >>> Printf.printf "%s\n" $ pubKeyHashFromApi "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d --- +{- | + +>>> Printf.printf "%s\n" $ pubKeyHashFromApi "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d +-} instance Printf.PrintfArg GYPubKeyHash where - formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . pubKeyHashToApi + formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . pubKeyHashToApi + +{- | --- | --- --- >>> Csv.toField @GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- +>>> Csv.toField @GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +"e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +-} instance Csv.ToField GYPubKeyHash where - toField = Api.serialiseToRawBytesHex . pubKeyHashToApi - --- | --- --- >>> Csv.runParser $ Csv.parseField @GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- Right (GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") --- --- >>> Csv.runParser $ Csv.parseField @GYPubKeyHash "not a pubkey hash" --- Left "RawBytesHexErrorBase16DecodeFail \"not a pubkey hash\" \"invalid bytestring size\"" --- + toField = Api.serialiseToRawBytesHex . pubKeyHashToApi + +{- | + +>>> Csv.runParser $ Csv.parseField @GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +Right (GYPubKeyHash "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d") + +>>> Csv.runParser $ Csv.parseField @GYPubKeyHash "not a pubkey hash" +Left "RawBytesHexErrorBase16DecodeFail \"not a pubkey hash\" \"invalid bytestring size\"" +-} instance Csv.FromField GYPubKeyHash where - parseField = either (fail . show) (return . pubKeyHashFromApi) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsPaymentKey) + parseField = either (fail . show) (return . pubKeyHashFromApi) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsPaymentKey) ------------------------------------------------------------------------------- -- swagger schema ------------------------------------------------------------------------------- - instance Swagger.ToSchema GYPubKeyHash where - declareNamedSchema _ = pure $ Swagger.named "GYPubKeyHash" $ mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "hex" - & Swagger.description ?~ "The hash of a public key." - & Swagger.example ?~ toJSON ("e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" :: Text) - & Swagger.maxLength ?~ 56 - & Swagger.minLength ?~ 56 + declareNamedSchema _ = + pure $ + Swagger.named "GYPubKeyHash" $ + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "hex" + & Swagger.description + ?~ "The hash of a public key." + & Swagger.example + ?~ toJSON ("e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" :: Text) + & Swagger.maxLength + ?~ 56 + & Swagger.minLength + ?~ 56 diff --git a/src/GeniusYield/Types/Rational.hs b/src/GeniusYield/Types/Rational.hs index 1aed289e..0ce15491 100644 --- a/src/GeniusYield/Types/Rational.hs +++ b/src/GeniusYield/Types/Rational.hs @@ -1,47 +1,47 @@ -{-| +{- | Module : GeniusYield.Types.Rational Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Types.Rational - ( GYRational - , rationalFromGHC - , rationalToGHC - , rationalFromPlutus - , rationalToPlutus - ) where - -import GeniusYield.Imports - -import Control.Lens ((?~)) -import qualified Data.Aeson as Aeson -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Swagger.Lens () -import qualified Data.Text as Text -import qualified Data.Text.Read as Text -import qualified PlutusTx.Ratio as Plutus -import qualified Web.HttpApiData as Web -import qualified Web.Internal.HttpApiData as Web - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import Text.Printf (printf) --- >>> import qualified Web.HttpApiData as Web +module GeniusYield.Types.Rational ( + GYRational, + rationalFromGHC, + rationalToGHC, + rationalFromPlutus, + rationalToPlutus, +) where + +import GeniusYield.Imports + +import Control.Lens ((?~)) +import Data.Aeson qualified as Aeson +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Swagger.Lens qualified () +import Data.Text qualified as Text +import Data.Text.Read qualified as Text +import PlutusTx.Ratio qualified as Plutus +import Web.HttpApiData qualified as Web +import Web.Internal.HttpApiData qualified as Web + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import Text.Printf (printf) +>>> import qualified Web.HttpApiData as Web +-} ------------------------------------------------------------------------------- -- GYRational ------------------------------------------------------------------------------- newtype GYRational = GYRational Rational - deriving stock (Show, Read, Generic) - deriving newtype (Eq, Ord, Num, Fractional, Real, RealFrac) + deriving stock (Show, Read, Generic) + deriving newtype (Eq, Ord, Num, Fractional, Real, RealFrac) rationalFromGHC :: Rational -> GYRational rationalFromGHC = coerce @@ -55,55 +55,63 @@ rationalFromPlutus = rationalFromGHC . Plutus.toGHC rationalToPlutus :: GYRational -> Plutus.Rational rationalToPlutus = Plutus.fromGHC . rationalToGHC --- | --- --- >>> printf "%6.4f\n" $ fromRational @GYRational 0.123 --- 0.1230 --- +{- | + +>>> printf "%6.4f\n" $ fromRational @GYRational 0.123 +0.1230 +-} instance PrintfArg GYRational where - formatArg = formatArg . fromRational @Double . coerce + formatArg = formatArg . fromRational @Double . coerce + +{- | --- | --- --- >>> Web.parseUrlPiece @GYRational "0.123" --- Right (GYRational (123 % 1000)) --- +>>> Web.parseUrlPiece @GYRational "0.123" +Right (GYRational (123 % 1000)) +-} instance Web.FromHttpApiData GYRational where parseUrlPiece = Web.runReader Text.rational --- | --- --- >>> LBS8.putStrLn $ Aeson.encode (fromRational @GYRational 0.123) --- "0.123" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode (fromRational @GYRational 0.123) +"0.123" +-} instance Aeson.ToJSON GYRational where - toJSON = Aeson.toJSON . show . fromRational @Double . coerce - --- | --- --- >>> Aeson.decode @GYRational "\"0.123\"" --- Just (GYRational (123 % 1000)) --- --- >>> Aeson.eitherDecode @GYRational "\"Haskell\"" --- Left "Error in $: could not parse: `Haskell' (input does not start with a digit)" --- + toJSON = Aeson.toJSON . show . fromRational @Double . coerce + +{- | + +>>> Aeson.decode @GYRational "\"0.123\"" +Just (GYRational (123 % 1000)) + +>>> Aeson.eitherDecode @GYRational "\"Haskell\"" +Left "Error in $: could not parse: `Haskell' (input does not start with a digit)" +-} instance Aeson.FromJSON GYRational where - parseJSON = Aeson.withText "GYRational" $ \t -> - case Web.parseUrlPiece t of - Left err -> fail $ Text.unpack err - Right x -> return x + parseJSON = Aeson.withText "GYRational" $ \t -> + case Web.parseUrlPiece t of + Left err -> fail $ Text.unpack err + Right x -> return x ------------------------------------------------------------------------------- -- swagger schema ------------------------------------------------------------------------------- instance Swagger.ToSchema GYRational where - declareNamedSchema p = Swagger.plain $ Swagger.paramSchemaToSchema p - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "float" - & Swagger.example ?~ toJSON ("0.125" :: String) + declareNamedSchema p = + Swagger.plain $ + Swagger.paramSchemaToSchema p + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "float" + & Swagger.example + ?~ toJSON ("0.125" :: String) instance Swagger.ToParamSchema GYRational where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "float" + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "float" diff --git a/src/GeniusYield/Types/Redeemer.hs b/src/GeniusYield/Types/Redeemer.hs index cb3751c1..e848eeb9 100644 --- a/src/GeniusYield/Types/Redeemer.hs +++ b/src/GeniusYield/Types/Redeemer.hs @@ -1,37 +1,38 @@ -{-| +{- | Module : GeniusYield.Types.Redeemer Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Redeemer ( - GYRedeemer, - redeemerToApi, - redeemerFromApi, - redeemerToPlutus, - redeemerToPlutus', - redeemerFromPlutus, - redeemerFromPlutus', - redeemerFromPlutusData, - unitRedeemer, - nothingRedeemer, + GYRedeemer, + redeemerToApi, + redeemerFromApi, + redeemerToPlutus, + redeemerToPlutus', + redeemerFromPlutus, + redeemerFromPlutus', + redeemerFromPlutusData, + unitRedeemer, + nothingRedeemer, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api -import GeniusYield.Imports ((>>>)) -import qualified PlutusLedgerApi.V1 as PlutusV1 -import qualified PlutusTx +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api +import GeniusYield.Imports ((>>>)) +import PlutusLedgerApi.V1 qualified as PlutusV1 +import PlutusTx qualified newtype GYRedeemer = GYRedeemer PlutusTx.BuiltinData deriving (Eq) instance Show GYRedeemer where - showsPrec d (GYRedeemer x) = showParen (d > 10) - -- Show BuiltinData doesn't respect precedence. - $ showString "redeemerFromPlutus' (BuiltinData (" + showsPrec d (GYRedeemer x) = + showParen (d > 10) + -- Show BuiltinData doesn't respect precedence. + $ + showString "redeemerFromPlutus' (BuiltinData (" . shows x . showString "))" @@ -47,7 +48,7 @@ redeemerFromPlutus (PlutusV1.Redeemer x) = GYRedeemer x redeemerFromPlutus' :: PlutusTx.BuiltinData -> GYRedeemer redeemerFromPlutus' = GYRedeemer -redeemerFromPlutusData :: PlutusTx.ToData a => a -> GYRedeemer +redeemerFromPlutusData :: (PlutusTx.ToData a) => a -> GYRedeemer redeemerFromPlutusData = GYRedeemer . PlutusTx.toBuiltinData redeemerToApi :: GYRedeemer -> Api.HashableScriptData @@ -56,22 +57,22 @@ redeemerToApi = redeemerToPlutus' >>> PlutusTx.builtinDataToData >>> Api.fromPlu redeemerFromApi :: Api.HashableScriptData -> GYRedeemer redeemerFromApi = GYRedeemer . PlutusTx.dataToBuiltinData . Api.toPlutusData . Api.getScriptData --- | Unit redeemer --- --- @'redeemerFromPlutusData' ()@. --- --- Often used as an arbitrary redeemer. --- +{- | Unit redeemer + +@'redeemerFromPlutusData' ()@. + +Often used as an arbitrary redeemer. +-} unitRedeemer :: GYRedeemer unitRedeemer = redeemerFromPlutusData () --- | A @'redeemerFromPlutusData' (Nothing \@a)@ for any @a@. --- --- >>> nothingRedeemer --- redeemerFromPlutus' (BuiltinData (Constr 1 [])) --- --- >>> redeemerFromPlutusData (Nothing @Integer) --- redeemerFromPlutus' (BuiltinData (Constr 1 [])) --- +{- | A @'redeemerFromPlutusData' (Nothing \@a)@ for any @a@. + +>>> nothingRedeemer +redeemerFromPlutus' (BuiltinData (Constr 1 [])) + +>>> redeemerFromPlutusData (Nothing @Integer) +redeemerFromPlutus' (BuiltinData (Constr 1 [])) +-} nothingRedeemer :: GYRedeemer nothingRedeemer = redeemerFromPlutusData (Nothing @()) diff --git a/src/GeniusYield/Types/Script.hs b/src/GeniusYield/Types/Script.hs index 74e0edee..355eb8ff 100644 --- a/src/GeniusYield/Types/Script.hs +++ b/src/GeniusYield/Types/Script.hs @@ -1,187 +1,191 @@ -{-| +{- | Module : GeniusYield.Types.Script Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Script ( - -- * Validator - GYValidator, - validatorFromPlutus, - validatorFromSerialisedScript, - validatorToSerialisedScript, - validatorToApi, - validatorFromApi, - validatorToApiPlutusScriptWitness, - - -- ** File operations - writeValidator, - readValidator, - - -- ** Selectors - validatorHash, - validatorPlutusHash, - validatorApiHash, - validatorVersion, - - -- * ValidatorHash - GYValidatorHash, - validatorHashToApi, - validatorHashToPlutus, - validatorHashFromApi, - validatorHashFromPlutus, - - -- * ScriptHash - GYScriptHash, - scriptHashFromApi, - scriptHashToApi, - scriptHashFromLedger, - scriptHashToLedger, - scriptHashToPlutus, - - -- * MintingPolicy - GYMintingPolicy, - mintingPolicyId, - mintingPolicyVersion, - mintingPolicyVersionFromWitness, - mintingPolicyFromPlutus, - mintingPolicyFromSerialisedScript, - mintingPolicyToSerialisedScript, - mintingPolicyToApi, - mintingPolicyIdToText, - mintingPolicyIdFromText, - mintingPolicyFromApi, - mintingPolicyToApiPlutusScriptWitness, - - -- * Witness for Minting Policy - GYMintScript (..), - mintingPolicyIdFromWitness, - gyMintScriptToSerialisedScript, - gyMintingScriptWitnessToApiPlutusSW, - - -- ** File operations - writeMintingPolicy, - readMintingPolicy, - - -- ** Selectors - mintingPolicyCurrencySymbol, - mintingPolicyApiId, - mintingPolicyApiIdFromWitness, - - -- * MintingPolicyId - GYMintingPolicyId, - mintingPolicyIdToApi, - mintingPolicyIdFromApi, - mintingPolicyIdToCurrencySymbol, - mintingPolicyIdFromCurrencySymbol, - mintingPolicyIdCurrencySymbol, - - -- * StakeValidator - GYStakeValidator, - stakeValidatorVersion, - stakeValidatorVersionFromWitness, - stakeValidatorFromPlutus, - stakeValidatorFromSerialisedScript, - stakeValidatorToSerialisedScript, - stakeValidatorToApi, - stakeValidatorFromApi, - stakeValidatorToApiPlutusScriptWitness, - - -- * Witness for stake validator - GYStakeValScript (..), - gyStakeValScriptToSerialisedScript, - gyStakeValScriptWitnessToApiPlutusSW, - - -- ** Stake validator selectors - stakeValidatorHash, - stakeValidatorPlutusHash, - stakeValidatorApiHash, - - -- * StakeValidatorHash - GYStakeValidatorHash, - stakeValidatorHashToApi, - stakeValidatorHashToPlutus, - stakeValidatorHashFromApi, - stakeValidatorHashFromPlutus, - - -- ** File operations - writeStakeValidator, - readStakeValidator, - - -- * Script - GYScript, - hashScript, - scriptVersion, - validatorToScript, - mintingPolicyToScript, - stakeValidatorToScript, - scriptToApi, - scriptFromCBOR, - scriptFromCBOR', - scriptFromPlutus, - scriptFromSerialisedScript, - scriptToSerialisedScript, - scriptApiHash, - scriptPlutusHash, - someScriptPlutusHash, - someScriptToReferenceApi, - someScriptFromReferenceApi, - referenceScriptToApiPlutusScriptWitness, - apiHashToPlutus, - scriptSize, - - -- ** File operations - writeScript, - readScript, - - -- * Any Script - GYAnyScript (..), - hashAnyScript, - anyScriptToApiScriptInEra, - - -- * Simple Script - module SimpleScript + -- * Validator + GYValidator, + validatorFromPlutus, + validatorFromSerialisedScript, + validatorToSerialisedScript, + validatorToApi, + validatorFromApi, + validatorToApiPlutusScriptWitness, + + -- ** File operations + writeValidator, + readValidator, + + -- ** Selectors + validatorHash, + validatorPlutusHash, + validatorApiHash, + validatorVersion, + + -- * ValidatorHash + GYValidatorHash, + validatorHashToApi, + validatorHashToPlutus, + validatorHashFromApi, + validatorHashFromPlutus, + + -- * ScriptHash + GYScriptHash, + scriptHashFromApi, + scriptHashToApi, + scriptHashFromLedger, + scriptHashToLedger, + scriptHashToPlutus, + + -- * MintingPolicy + GYMintingPolicy, + mintingPolicyId, + mintingPolicyVersion, + mintingPolicyVersionFromWitness, + mintingPolicyFromPlutus, + mintingPolicyFromSerialisedScript, + mintingPolicyToSerialisedScript, + mintingPolicyToApi, + mintingPolicyIdToText, + mintingPolicyIdFromText, + mintingPolicyFromApi, + mintingPolicyToApiPlutusScriptWitness, + + -- * Witness for Minting Policy + GYMintScript (..), + mintingPolicyIdFromWitness, + gyMintScriptToSerialisedScript, + gyMintingScriptWitnessToApiPlutusSW, + + -- ** File operations + writeMintingPolicy, + readMintingPolicy, + + -- ** Selectors + mintingPolicyCurrencySymbol, + mintingPolicyApiId, + mintingPolicyApiIdFromWitness, + + -- * MintingPolicyId + GYMintingPolicyId, + mintingPolicyIdToApi, + mintingPolicyIdFromApi, + mintingPolicyIdToCurrencySymbol, + mintingPolicyIdFromCurrencySymbol, + mintingPolicyIdCurrencySymbol, + + -- * StakeValidator + GYStakeValidator, + stakeValidatorVersion, + stakeValidatorVersionFromWitness, + stakeValidatorFromPlutus, + stakeValidatorFromSerialisedScript, + stakeValidatorToSerialisedScript, + stakeValidatorToApi, + stakeValidatorFromApi, + stakeValidatorToApiPlutusScriptWitness, + + -- * Witness for stake validator + GYStakeValScript (..), + gyStakeValScriptToSerialisedScript, + gyStakeValScriptWitnessToApiPlutusSW, + + -- ** Stake validator selectors + stakeValidatorHash, + stakeValidatorPlutusHash, + stakeValidatorApiHash, + + -- * StakeValidatorHash + GYStakeValidatorHash, + stakeValidatorHashToApi, + stakeValidatorHashToPlutus, + stakeValidatorHashFromApi, + stakeValidatorHashFromPlutus, + + -- ** File operations + writeStakeValidator, + readStakeValidator, + + -- * Script + GYScript, + hashScript, + scriptVersion, + validatorToScript, + mintingPolicyToScript, + stakeValidatorToScript, + scriptToApi, + scriptFromCBOR, + scriptFromCBOR', + scriptFromPlutus, + scriptFromSerialisedScript, + scriptToSerialisedScript, + scriptApiHash, + scriptPlutusHash, + someScriptPlutusHash, + someScriptToReferenceApi, + someScriptFromReferenceApi, + referenceScriptToApiPlutusScriptWitness, + apiHashToPlutus, + scriptSize, + + -- ** File operations + writeScript, + readScript, + + -- * Any Script + GYAnyScript (..), + hashAnyScript, + anyScriptToApiScriptInEra, + + -- * Simple Script + module SimpleScript, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Script as Api -import qualified Cardano.Api.Shelley as Api.S -import Cardano.Ledger.SafeHash (SafeToHash (originalBytesSize)) -import Control.Lens ((?~)) -import Data.Aeson.Types (FromJSONKey (fromJSONKey), - FromJSONKeyFunction (FromJSONKeyTextParser), - ToJSONKey (toJSONKey), - toJSONKeyText) -import qualified Data.Attoparsec.ByteString.Char8 as Atto -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as BS16 -import Data.ByteString.Short (ShortByteString) -import Data.GADT.Compare -import Data.GADT.Show -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Text as Text -import qualified Data.Text.Encoding as TE -import GeniusYield.Imports -import GeniusYield.Types.Era (ApiEra) -import GeniusYield.Types.Ledger (PlutusToCardanoError (..)) -import GeniusYield.Types.PlutusVersion -import GeniusYield.Types.Script.ScriptHash -import GeniusYield.Types.Script.SimpleScript as SimpleScript -import GeniusYield.Types.TxOutRef (GYTxOutRef, - txOutRefToApi) -import qualified PlutusLedgerApi.Common as Plutus -import qualified PlutusLedgerApi.V1 as PlutusV1 -import qualified PlutusTx -import qualified PlutusTx.Builtins as PlutusTx -import qualified Text.Printf as Printf -import qualified Web.HttpApiData as Web - --- $setup --- --- >>> import GeniusYield.Imports +import Cardano.Api qualified as Api +import Cardano.Api.Script qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Ledger.SafeHash (SafeToHash (originalBytesSize)) +import Control.Lens ((?~)) +import Data.Aeson.Types ( + FromJSONKey (fromJSONKey), + FromJSONKeyFunction (FromJSONKeyTextParser), + ToJSONKey (toJSONKey), + toJSONKeyText, + ) +import Data.Attoparsec.ByteString.Char8 qualified as Atto +import Data.ByteString (ByteString) +import Data.ByteString.Base16 qualified as BS16 +import Data.ByteString.Short (ShortByteString) +import Data.GADT.Compare +import Data.GADT.Show +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import GeniusYield.Imports +import GeniusYield.Types.Era (ApiEra) +import GeniusYield.Types.Ledger (PlutusToCardanoError (..)) +import GeniusYield.Types.PlutusVersion +import GeniusYield.Types.Script.ScriptHash +import GeniusYield.Types.Script.SimpleScript as SimpleScript +import GeniusYield.Types.TxOutRef ( + GYTxOutRef, + txOutRefToApi, + ) +import PlutusLedgerApi.Common qualified as Plutus +import PlutusLedgerApi.V1 qualified as PlutusV1 +import PlutusTx qualified +import PlutusTx.Builtins qualified as PlutusTx +import Text.Printf qualified as Printf +import Web.HttpApiData qualified as Web + +{- $setup + +>>> import GeniusYield.Imports +-} ------------------------------------------------------------------------------- -- Validator @@ -198,10 +202,10 @@ instance GShow GYValidator where -- FIXME: Seeing inclusion of CIP-69, we should likely get rid of all these different types of scripts and just have one type of script. -- To make it use BuiltinUnit. -validatorFromPlutus :: forall v. SingPlutusVersionI v => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYValidator v +validatorFromPlutus :: forall v. (SingPlutusVersionI v) => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYValidator v validatorFromPlutus = coerce (scriptFromPlutus @v) -validatorFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYValidator v +validatorFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYValidator v validatorFromSerialisedScript = coerce . scriptFromSerialisedScript validatorToSerialisedScript :: GYValidator v -> Plutus.SerialisedScript @@ -213,7 +217,7 @@ validatorToScript = coerce validatorToApi :: GYValidator v -> Api.PlutusScript (PlutusVersionToApi v) validatorToApi = coerce scriptToApi -validatorFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYValidator v +validatorFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYValidator v validatorFromApi = coerce (scriptFromApi @v) validatorHash :: GYValidator v -> GYValidatorHash @@ -228,43 +232,41 @@ validatorApiHash = coerce scriptApiHash validatorVersion :: GYValidator v -> SingPlutusVersion v validatorVersion = coerce scriptVersion -validatorToApiPlutusScriptWitness - :: GYValidator v - -> Api.ScriptDatum Api.WitCtxTxIn - -> Api.ScriptRedeemer - -> Api.ExecutionUnits - -> Api.ScriptWitness Api.WitCtxTxIn ApiEra +validatorToApiPlutusScriptWitness :: + GYValidator v -> + Api.ScriptDatum Api.WitCtxTxIn -> + Api.ScriptRedeemer -> + Api.ExecutionUnits -> + Api.ScriptWitness Api.WitCtxTxIn ApiEra validatorToApiPlutusScriptWitness (GYValidator s) = - scriptToApiPlutusScriptWitness s + scriptToApiPlutusScriptWitness s -- | Writes a validator to a file. --- writeValidator :: FilePath -> GYValidator v -> IO () writeValidator file = writeScriptCore "Validator" file . coerce -- | Reads a validator from a file. --- -readValidator :: SingPlutusVersionI v => FilePath -> IO (GYValidator v) +readValidator :: (SingPlutusVersionI v) => FilePath -> IO (GYValidator v) readValidator = coerce readScript newtype GYValidatorHash = GYValidatorHash Api.ScriptHash deriving stock (Show, Eq, Ord) --- | --- --- >>> "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYValidatorHash --- GYValidatorHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" --- +{- | + +>>> "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYValidatorHash +GYValidatorHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" +-} instance IsString GYValidatorHash where - fromString = GYValidatorHash . fromString + fromString = GYValidatorHash . fromString + +{- | --- | --- --- >>> printf "%s" ("cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYValidatorHash) --- cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0 --- +>>> printf "%s" ("cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYValidatorHash) +cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0 +-} instance Printf.PrintfArg GYValidatorHash where - formatArg (GYValidatorHash h) = formatArg $ init $ tail $ show h + formatArg (GYValidatorHash h) = formatArg $ init $ tail $ show h validatorHashToPlutus :: GYValidatorHash -> PlutusV1.ScriptHash validatorHashToPlutus = apiHashToPlutus . validatorHashToApi @@ -275,21 +277,21 @@ validatorHashToApi = coerce validatorHashFromApi :: Api.ScriptHash -> GYValidatorHash validatorHashFromApi = coerce --- | --- --- >>> validatorHashFromPlutus "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" --- Right (GYValidatorHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0") --- --- >>> validatorHashFromPlutus "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7" --- Left (DeserialiseRawBytesError {ptceTag = "validatorHashFromPlutus: cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7, error: SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise ScriptHash\"}"}) --- +{- | + +>>> validatorHashFromPlutus "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" +Right (GYValidatorHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0") + +>>> validatorHashFromPlutus "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7" +Left (DeserialiseRawBytesError {ptceTag = "validatorHashFromPlutus: cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7, error: SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise ScriptHash\"}"}) +-} validatorHashFromPlutus :: PlutusV1.ScriptHash -> Either PlutusToCardanoError GYValidatorHash validatorHashFromPlutus vh@(PlutusV1.ScriptHash ibs) = - bimap - (\e -> DeserialiseRawBytesError $ Text.pack $ "validatorHashFromPlutus: " <> show vh <> ", error: " <> show e) - validatorHashFromApi - $ Api.deserialiseFromRawBytes Api.AsScriptHash $ PlutusTx.fromBuiltin ibs - + bimap + (\e -> DeserialiseRawBytesError $ Text.pack $ "validatorHashFromPlutus: " <> show vh <> ", error: " <> show e) + validatorHashFromApi + $ Api.deserialiseFromRawBytes Api.AsScriptHash + $ PlutusTx.fromBuiltin ibs ------------------------------------------------------------------------------- -- Minting Policy @@ -315,13 +317,13 @@ mintingPolicyId :: GYMintingPolicy v -> GYMintingPolicyId mintingPolicyId = coerce scriptApiHash mintingPolicyIdFromWitness :: GYMintScript v -> GYMintingPolicyId -mintingPolicyIdFromWitness (GYMintScript p) = mintingPolicyId p +mintingPolicyIdFromWitness (GYMintScript p) = mintingPolicyId p mintingPolicyIdFromWitness (GYMintReference _ s) = mintingPolicyId $ coerce s -mintingPolicyFromPlutus :: forall v. SingPlutusVersionI v => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYMintingPolicy v +mintingPolicyFromPlutus :: forall v. (SingPlutusVersionI v) => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYMintingPolicy v mintingPolicyFromPlutus = coerce (scriptFromPlutus @v) -mintingPolicyFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYMintingPolicy v +mintingPolicyFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYMintingPolicy v mintingPolicyFromSerialisedScript = coerce . scriptFromSerialisedScript mintingPolicyToSerialisedScript :: GYMintingPolicy v -> Plutus.SerialisedScript @@ -333,7 +335,7 @@ mintingPolicyToScript = coerce mintingPolicyToApi :: GYMintingPolicy v -> Api.PlutusScript (PlutusVersionToApi v) mintingPolicyToApi = coerce scriptToApi -mintingPolicyFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYMintingPolicy v +mintingPolicyFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYMintingPolicy v mintingPolicyFromApi = coerce (scriptFromApi @v) mintingPolicyCurrencySymbol :: GYMintingPolicy v -> PlutusV1.CurrencySymbol @@ -345,105 +347,114 @@ mintingPolicyApiId = coerce . mintingPolicyId mintingPolicyApiIdFromWitness :: GYMintScript v -> Api.PolicyId mintingPolicyApiIdFromWitness = coerce . mintingPolicyIdFromWitness -mintingPolicyToApiPlutusScriptWitness - :: GYMintingPolicy v - -> Api.ScriptRedeemer - -> Api.ExecutionUnits - -> Api.ScriptWitness Api.WitCtxMint ApiEra +mintingPolicyToApiPlutusScriptWitness :: + GYMintingPolicy v -> + Api.ScriptRedeemer -> + Api.ExecutionUnits -> + Api.ScriptWitness Api.WitCtxMint ApiEra mintingPolicyToApiPlutusScriptWitness (GYMintingPolicy s) = - scriptToApiPlutusScriptWitness s Api.NoScriptDatumForMint + scriptToApiPlutusScriptWitness s Api.NoScriptDatumForMint data GYMintScript (u :: PlutusVersion) where - -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction. - GYMintScript :: v `VersionIsGreaterOrEqual` u => GYMintingPolicy v -> GYMintScript u - - -- | Reference inputs can be only used in V2 transactions. - GYMintReference :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYMintScript v + -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction. + GYMintScript :: (v `VersionIsGreaterOrEqual` u) => GYMintingPolicy v -> GYMintScript u + -- | Reference inputs can be only used in V2 transactions. + GYMintReference :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYMintScript v deriving instance Show (GYMintScript v) instance Eq (GYMintScript v) where - GYMintReference r s == GYMintReference r' s' = r == r' && s == s' - GYMintScript p == GYMintScript p' = defaultEq p p' - _ == _ = False + GYMintReference r s == GYMintReference r' s' = r == r' && s == s' + GYMintScript p == GYMintScript p' = defaultEq p p' + _ == _ = False instance Ord (GYMintScript v) where - GYMintReference r s `compare` GYMintReference r' s' = compare r r' <> compare s s' - GYMintReference _ _ `compare` _ = LT - GYMintScript p `compare` GYMintScript p' = defaultCompare p p' - GYMintScript _ `compare` _ = GT + GYMintReference r s `compare` GYMintReference r' s' = compare r r' <> compare s s' + GYMintReference _ _ `compare` _ = LT + GYMintScript p `compare` GYMintScript p' = defaultCompare p p' + GYMintScript _ `compare` _ = GT gyMintScriptToSerialisedScript :: GYMintScript u -> Plutus.SerialisedScript gyMintScriptToSerialisedScript (GYMintScript mp) = coerce mp & scriptToSerialisedScript & coerce gyMintScriptToSerialisedScript (GYMintReference _ s) = scriptToSerialisedScript s & coerce -gyMintingScriptWitnessToApiPlutusSW - :: GYMintScript u - -> Api.S.ScriptRedeemer - -> Api.S.ExecutionUnits - -> Api.S.ScriptWitness Api.S.WitCtxMint ApiEra +gyMintingScriptWitnessToApiPlutusSW :: + GYMintScript u -> + Api.S.ScriptRedeemer -> + Api.S.ExecutionUnits -> + Api.S.ScriptWitness Api.S.WitCtxMint ApiEra gyMintingScriptWitnessToApiPlutusSW (GYMintScript p) = mintingPolicyToApiPlutusScriptWitness p gyMintingScriptWitnessToApiPlutusSW (GYMintReference r s) = - referenceScriptToApiPlutusScriptWitness r s + referenceScriptToApiPlutusScriptWitness + r + s Api.NoScriptDatumForMint -- | Writes a minting policy to a file. --- writeMintingPolicy :: FilePath -> GYMintingPolicy v -> IO () writeMintingPolicy file = writeScriptCore "Minting Policy" file . coerce -- | Reads a minting policy from a file. --- -readMintingPolicy :: SingPlutusVersionI v => FilePath -> IO (GYMintingPolicy v) +readMintingPolicy :: (SingPlutusVersionI v) => FilePath -> IO (GYMintingPolicy v) readMintingPolicy = coerce readScript -- | Minting policy identifier, also a currency symbol. newtype GYMintingPolicyId = GYMintingPolicyId Api.PolicyId - deriving stock (Eq, Ord) + deriving stock (Eq, Ord) deriving newtype (ToJSON, FromJSON) instance ToJSONKey GYMintingPolicyId where - toJSONKey = toJSONKeyText mintingPolicyIdToText + toJSONKey = toJSONKeyText mintingPolicyIdToText instance FromJSONKey GYMintingPolicyId where - fromJSONKey = FromJSONKeyTextParser (either fail pure . mintingPolicyIdFromText) + fromJSONKey = FromJSONKeyTextParser (either fail pure . mintingPolicyIdFromText) --- | --- --- >>> fromString "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" :: GYMintingPolicyId --- "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" --- +{- | + +>>> fromString "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" :: GYMintingPolicyId +"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" +-} instance IsString GYMintingPolicyId where - fromString = GYMintingPolicyId . fromString + fromString = GYMintingPolicyId . fromString instance Show GYMintingPolicyId where - showsPrec d (GYMintingPolicyId s) = showsPrec d s + showsPrec d (GYMintingPolicyId s) = showsPrec d s instance Web.FromHttpApiData GYMintingPolicyId where parseUrlPiece = first Text.pack . Atto.parseOnly parser . TE.encodeUtf8 where parser :: Atto.Parser GYMintingPolicyId - parser = do + parser = do cs <- Atto.takeWhile1 isHexDigit case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of - Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x + Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x Right cs' -> return $ mintingPolicyIdFromApi cs' instance Web.ToHttpApiData GYMintingPolicyId where toUrlPiece = mintingPolicyIdToText instance Swagger.ToParamSchema GYMintingPolicyId where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "hex" - & Swagger.maxLength ?~ 56 - & Swagger.minLength ?~ 56 + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "hex" + & Swagger.maxLength + ?~ 56 + & Swagger.minLength + ?~ 56 instance Swagger.ToSchema GYMintingPolicyId where - declareNamedSchema _ = pure $ Swagger.named "GYMintingPolicyId" $ Swagger.paramSchemaToSchema (Proxy @GYMintingPolicyId) - & Swagger.description ?~ "This is the hash of a minting policy script." - & Swagger.example ?~ toJSON ("ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" :: Text) + declareNamedSchema _ = + pure $ + Swagger.named "GYMintingPolicyId" $ + Swagger.paramSchemaToSchema (Proxy @GYMintingPolicyId) + & Swagger.description + ?~ "This is the hash of a minting policy script." + & Swagger.example + ?~ toJSON ("ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" :: Text) mintingPolicyIdToApi :: GYMintingPolicyId -> Api.PolicyId mintingPolicyIdToApi = coerce @@ -458,23 +469,26 @@ mintingPolicyIdCurrencySymbol = coerce $ PlutusTx.toBuiltin . Api.serialiseToRaw mintingPolicyIdToCurrencySymbol :: GYMintingPolicyId -> PlutusV1.CurrencySymbol mintingPolicyIdToCurrencySymbol = mintingPolicyIdCurrencySymbol --- | --- --- >>> mintingPolicyIdFromCurrencySymbol $ mintingPolicyIdToCurrencySymbol "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" --- Right "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" --- +{- | + +>>> mintingPolicyIdFromCurrencySymbol $ mintingPolicyIdToCurrencySymbol "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" +Right "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" +-} mintingPolicyIdFromCurrencySymbol :: PlutusV1.CurrencySymbol -> Either PlutusToCardanoError GYMintingPolicyId mintingPolicyIdFromCurrencySymbol cs = - bimap - (\e -> DeserialiseRawBytesError $ Text.pack $ "validatorHashFromPlutus: " <> show cs <> ", error: " <> show e) - mintingPolicyIdFromApi - $ Api.deserialiseFromRawBytes Api.AsPolicyId $ PlutusTx.fromBuiltin $ PlutusV1.unCurrencySymbol cs + bimap + (\e -> DeserialiseRawBytesError $ Text.pack $ "validatorHashFromPlutus: " <> show cs <> ", error: " <> show e) + mintingPolicyIdFromApi + $ Api.deserialiseFromRawBytes Api.AsPolicyId + $ PlutusTx.fromBuiltin + $ PlutusV1.unCurrencySymbol cs mintingPolicyIdToText :: GYMintingPolicyId -> Text mintingPolicyIdToText = Api.serialiseToRawBytesHexText . Api.unPolicyId . mintingPolicyIdToApi mintingPolicyIdFromText :: Text -> Either String GYMintingPolicyId -mintingPolicyIdFromText policyid = bimap customError mintingPolicyIdFromApi +mintingPolicyIdFromText policyid = + bimap customError mintingPolicyIdFromApi . Api.deserialiseFromRawBytesHex Api.S.AsPolicyId $ TE.encodeUtf8 policyid where @@ -500,10 +514,10 @@ stakeValidatorVersionFromWitness :: GYStakeValScript v -> PlutusVersion stakeValidatorVersionFromWitness (GYStakeValScript mp) = fromSingPlutusVersion $ stakeValidatorVersion mp stakeValidatorVersionFromWitness (GYStakeValReference _ s) = fromSingPlutusVersion $ stakeValidatorVersion $ coerce s -stakeValidatorFromPlutus :: forall v. SingPlutusVersionI v => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYStakeValidator v +stakeValidatorFromPlutus :: forall v. (SingPlutusVersionI v) => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYStakeValidator v stakeValidatorFromPlutus = coerce (scriptFromPlutus @v) -stakeValidatorFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYStakeValidator v +stakeValidatorFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYStakeValidator v stakeValidatorFromSerialisedScript = coerce . scriptFromSerialisedScript stakeValidatorToSerialisedScript :: GYStakeValidator v -> Plutus.SerialisedScript @@ -515,49 +529,50 @@ stakeValidatorToScript = coerce stakeValidatorToApi :: GYStakeValidator v -> Api.PlutusScript (PlutusVersionToApi v) stakeValidatorToApi = coerce scriptToApi -stakeValidatorFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYStakeValidator v +stakeValidatorFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYStakeValidator v stakeValidatorFromApi = coerce (scriptFromApi @v) -stakeValidatorToApiPlutusScriptWitness - :: GYStakeValidator v - -> Api.ScriptRedeemer - -> Api.ExecutionUnits - -> Api.ScriptWitness Api.WitCtxStake ApiEra +stakeValidatorToApiPlutusScriptWitness :: + GYStakeValidator v -> + Api.ScriptRedeemer -> + Api.ExecutionUnits -> + Api.ScriptWitness Api.WitCtxStake ApiEra stakeValidatorToApiPlutusScriptWitness (GYStakeValidator s) = - scriptToApiPlutusScriptWitness s Api.NoScriptDatumForStake + scriptToApiPlutusScriptWitness s Api.NoScriptDatumForStake data GYStakeValScript (u :: PlutusVersion) where - -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction. - GYStakeValScript :: v `VersionIsGreaterOrEqual` u => GYStakeValidator v -> GYStakeValScript u - - -- | Reference inputs can be only used in V2 transactions. - GYStakeValReference :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYStakeValScript v + -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction. + GYStakeValScript :: (v `VersionIsGreaterOrEqual` u) => GYStakeValidator v -> GYStakeValScript u + -- | Reference inputs can be only used in V2 transactions. + GYStakeValReference :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYStakeValScript v deriving instance Show (GYStakeValScript v) instance Eq (GYStakeValScript v) where - GYStakeValReference r s == GYStakeValReference r' s' = r == r' && s == s' - GYStakeValScript p == GYStakeValScript p' = defaultEq p p' - _ == _ = False + GYStakeValReference r s == GYStakeValReference r' s' = r == r' && s == s' + GYStakeValScript p == GYStakeValScript p' = defaultEq p p' + _ == _ = False instance Ord (GYStakeValScript v) where - GYStakeValReference r s `compare` GYStakeValReference r' s' = compare r r' <> compare s s' - GYStakeValReference _ _ `compare` _ = LT - GYStakeValScript p `compare` GYStakeValScript p' = defaultCompare p p' - GYStakeValScript _ `compare` _ = GT + GYStakeValReference r s `compare` GYStakeValReference r' s' = compare r r' <> compare s s' + GYStakeValReference _ _ `compare` _ = LT + GYStakeValScript p `compare` GYStakeValScript p' = defaultCompare p p' + GYStakeValScript _ `compare` _ = GT gyStakeValScriptToSerialisedScript :: GYStakeValScript u -> Plutus.SerialisedScript gyStakeValScriptToSerialisedScript (GYStakeValScript mp) = coerce mp & scriptToSerialisedScript & coerce gyStakeValScriptToSerialisedScript (GYStakeValReference _ s) = scriptToSerialisedScript s & coerce -gyStakeValScriptWitnessToApiPlutusSW - :: GYStakeValScript u - -> Api.S.ScriptRedeemer - -> Api.S.ExecutionUnits - -> Api.S.ScriptWitness Api.S.WitCtxStake ApiEra +gyStakeValScriptWitnessToApiPlutusSW :: + GYStakeValScript u -> + Api.S.ScriptRedeemer -> + Api.S.ExecutionUnits -> + Api.S.ScriptWitness Api.S.WitCtxStake ApiEra gyStakeValScriptWitnessToApiPlutusSW (GYStakeValScript p) = stakeValidatorToApiPlutusScriptWitness p gyStakeValScriptWitnessToApiPlutusSW (GYStakeValReference r s) = - referenceScriptToApiPlutusScriptWitness r s + referenceScriptToApiPlutusScriptWitness + r + s Api.NoScriptDatumForStake stakeValidatorHash :: GYStakeValidator v -> GYStakeValidatorHash @@ -572,21 +587,21 @@ stakeValidatorApiHash = coerce scriptApiHash newtype GYStakeValidatorHash = GYStakeValidatorHash Api.ScriptHash deriving stock (Show, Eq, Ord) --- | --- --- >>> "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYStakeValidatorHash --- GYStakeValidatorHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" --- +{- | + +>>> "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYStakeValidatorHash +GYStakeValidatorHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" +-} instance IsString GYStakeValidatorHash where - fromString = GYStakeValidatorHash . fromString + fromString = GYStakeValidatorHash . fromString + +{- | --- | --- --- >>> printf "%s" ("cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYStakeValidatorHash) --- cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0 --- +>>> printf "%s" ("cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYStakeValidatorHash) +cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0 +-} instance Printf.PrintfArg GYStakeValidatorHash where - formatArg (GYStakeValidatorHash h) = formatArg $ init $ tail $ show h + formatArg (GYStakeValidatorHash h) = formatArg $ init $ tail $ show h stakeValidatorHashToPlutus :: GYStakeValidatorHash -> PlutusV1.ScriptHash stakeValidatorHashToPlutus = apiHashToPlutus . stakeValidatorHashToApi @@ -597,29 +612,28 @@ stakeValidatorHashToApi = coerce stakeValidatorHashFromApi :: Api.ScriptHash -> GYStakeValidatorHash stakeValidatorHashFromApi = coerce --- | --- --- >>> stakeValidatorHashFromPlutus "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" --- Right (GYStakeValidatorHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0") --- --- >>> stakeValidatorHashFromPlutus "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7" --- Left (DeserialiseRawBytesError {ptceTag = "stakeValidatorHashFromPlutus: cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7, error: SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise ScriptHash\"}"}) --- +{- | + +>>> stakeValidatorHashFromPlutus "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" +Right (GYStakeValidatorHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0") + +>>> stakeValidatorHashFromPlutus "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7" +Left (DeserialiseRawBytesError {ptceTag = "stakeValidatorHashFromPlutus: cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7, error: SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise ScriptHash\"}"}) +-} stakeValidatorHashFromPlutus :: PlutusV1.ScriptHash -> Either PlutusToCardanoError GYStakeValidatorHash stakeValidatorHashFromPlutus vh@(PlutusV1.ScriptHash ibs) = - bimap - (\e -> DeserialiseRawBytesError $ Text.pack $ "stakeValidatorHashFromPlutus: " <> show vh <> ", error: " <> show e) - stakeValidatorHashFromApi - $ Api.deserialiseFromRawBytes Api.AsScriptHash $ PlutusTx.fromBuiltin ibs + bimap + (\e -> DeserialiseRawBytesError $ Text.pack $ "stakeValidatorHashFromPlutus: " <> show vh <> ", error: " <> show e) + stakeValidatorHashFromApi + $ Api.deserialiseFromRawBytes Api.AsScriptHash + $ PlutusTx.fromBuiltin ibs -- | Writes a stake validator to a file. --- writeStakeValidator :: FilePath -> GYStakeValidator v -> IO () writeStakeValidator file = writeScriptCore "Stake Validator" file . coerce -- | Reads a stake validator from a file. --- -readStakeValidator :: SingPlutusVersionI v => FilePath -> IO (GYStakeValidator v) +readStakeValidator :: (SingPlutusVersionI v) => FilePath -> IO (GYStakeValidator v) readStakeValidator = coerce readScript ------------------------------------------------------------------------------- @@ -627,60 +641,63 @@ readStakeValidator = coerce readScript ------------------------------------------------------------------------------- -- | Plutus script -data GYScript (v :: PlutusVersion) = GYScript - !(SingPlutusVersion v) - !(Api.PlutusScript (PlutusVersionToApi v)) - !Api.ScriptHash - --- | Equality and comparison are on script hash. --- --- As hash is cryptographicly strong, and 'GYScript' constructor is not --- exposed, this works great. --- +data GYScript (v :: PlutusVersion) + = GYScript + !(SingPlutusVersion v) + !(Api.PlutusScript (PlutusVersionToApi v)) + !Api.ScriptHash + +{- | Equality and comparison are on script hash. + +As hash is cryptographicly strong, and 'GYScript' constructor is not +exposed, this works great. +-} instance Eq (GYScript v) where - (==) = defaultEq + (==) = defaultEq instance Ord (GYScript v) where - compare = defaultCompare + compare = defaultCompare instance Show (GYScript v) where - showsPrec d (GYScript _ _ h) = showParen (d > 10) - $ showString "GYScript " + showsPrec d (GYScript _ _ h) = + showParen (d > 10) $ + showString "GYScript " . showsPrec 11 h instance GEq GYScript where - geq (GYScript v1 _ h1) (GYScript v2 _ h2) = do - Refl <- geq v1 v2 - guard (h1 == h2) - return Refl + geq (GYScript v1 _ h1) (GYScript v2 _ h2) = do + Refl <- geq v1 v2 + guard (h1 == h2) + return Refl instance GCompare GYScript where - gcompare (GYScript v1 _ h1) (GYScript v2 _ h2) = case gcompare v1 v2 of - GEQ -> case compare h1 h2 of - EQ -> GEQ - LT -> GLT - GT -> GGT - GLT -> GLT - GGT -> GGT + gcompare (GYScript v1 _ h1) (GYScript v2 _ h2) = case gcompare v1 v2 of + GEQ -> case compare h1 h2 of + EQ -> GEQ + LT -> GLT + GT -> GGT + GLT -> GLT + GGT -> GGT instance GShow GYScript where - gshowsPrec = showsPrec + gshowsPrec = showsPrec -- In implementation we cache the api representation and hashes. hashScript :: GYScript v -> GYScriptHash hashScript = scriptApiHash >>> scriptHashFromApi -scriptFromPlutus :: forall v a. SingPlutusVersionI v => PlutusTx.CompiledCode a -> GYScript v +scriptFromPlutus :: forall v a. (SingPlutusVersionI v) => PlutusTx.CompiledCode a -> GYScript v scriptFromPlutus script = scriptFromApi $ Api.S.PlutusScriptSerialised $ Plutus.serialiseCompiledCode script -scriptFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYScript v +scriptFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYScript v scriptFromSerialisedScript serialisedScript = scriptFromApi $ Api.S.PlutusScriptSerialised @(PlutusVersionToApi v) serialisedScript scriptToSerialisedScript :: GYScript v -> ShortByteString -scriptToSerialisedScript script = scriptToApi script & \case - (Api.S.PlutusScriptSerialised s) -> s +scriptToSerialisedScript script = + scriptToApi script & \case + (Api.S.PlutusScriptSerialised s) -> s scriptVersion :: GYScript v -> SingPlutusVersion v scriptVersion (GYScript v _ _) = v @@ -690,54 +707,62 @@ scriptToApi (GYScript _ api _) = api someScriptToReferenceApi :: GYAnyScript -> Api.S.ReferenceScript ApiEra someScriptToReferenceApi (GYPlutusScript (GYScript v apiScript _)) = - Api.S.ReferenceScript - Api.S.BabbageEraOnwardsConway $ - Api.ScriptInAnyLang (Api.PlutusScriptLanguage v') $ - Api.PlutusScript v' apiScript + Api.S.ReferenceScript + Api.S.BabbageEraOnwardsConway + $ Api.ScriptInAnyLang (Api.PlutusScriptLanguage v') + $ Api.PlutusScript v' apiScript where v' = singPlutusVersionToApi v someScriptToReferenceApi (GYSimpleScript s) = - Api.S.ReferenceScript - Api.S.BabbageEraOnwardsConway $ - Api.ScriptInAnyLang Api.SimpleScriptLanguage $ Api.SimpleScript (simpleScriptToApi s) + Api.S.ReferenceScript + Api.S.BabbageEraOnwardsConway + $ Api.ScriptInAnyLang Api.SimpleScriptLanguage + $ Api.SimpleScript (simpleScriptToApi s) someScriptFromReferenceApi :: Api.S.ReferenceScript era -> Maybe GYAnyScript someScriptFromReferenceApi Api.S.ReferenceScriptNone = Nothing someScriptFromReferenceApi (Api.S.ReferenceScript Api.S.BabbageEraOnwardsBabbage _) = Nothing someScriptFromReferenceApi - (Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway - (Api.ScriptInAnyLang Api.SimpleScriptLanguage (Api.SimpleScript s))) = Just $ GYSimpleScript $ simpleScriptFromApi s + ( Api.S.ReferenceScript + Api.S.BabbageEraOnwardsConway + (Api.ScriptInAnyLang Api.SimpleScriptLanguage (Api.SimpleScript s)) + ) = Just $ GYSimpleScript $ simpleScriptFromApi s someScriptFromReferenceApi - (Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway - (Api.ScriptInAnyLang - (Api.PlutusScriptLanguage Api.PlutusScriptV1) - (Api.PlutusScript _ x) - ) - ) = Just (GYPlutusScript y) - where - y :: GYScript 'PlutusV1 - y = scriptFromApi x + ( Api.S.ReferenceScript + Api.S.BabbageEraOnwardsConway + ( Api.ScriptInAnyLang + (Api.PlutusScriptLanguage Api.PlutusScriptV1) + (Api.PlutusScript _ x) + ) + ) = Just (GYPlutusScript y) + where + y :: GYScript 'PlutusV1 + y = scriptFromApi x someScriptFromReferenceApi - (Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway - (Api.ScriptInAnyLang - (Api.PlutusScriptLanguage Api.PlutusScriptV2) - (Api.PlutusScript _ x) - ) - ) = Just (GYPlutusScript y) - where - y :: GYScript 'PlutusV2 - y = scriptFromApi x + ( Api.S.ReferenceScript + Api.S.BabbageEraOnwardsConway + ( Api.ScriptInAnyLang + (Api.PlutusScriptLanguage Api.PlutusScriptV2) + (Api.PlutusScript _ x) + ) + ) = Just (GYPlutusScript y) + where + y :: GYScript 'PlutusV2 + y = scriptFromApi x someScriptFromReferenceApi - (Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway - (Api.ScriptInAnyLang - (Api.PlutusScriptLanguage Api.PlutusScriptV3) - (Api.PlutusScript _ x))) = Just (GYPlutusScript y) - where - y :: GYScript 'PlutusV3 - y = scriptFromApi x + ( Api.S.ReferenceScript + Api.S.BabbageEraOnwardsConway + ( Api.ScriptInAnyLang + (Api.PlutusScriptLanguage Api.PlutusScriptV3) + (Api.PlutusScript _ x) + ) + ) = Just (GYPlutusScript y) + where + y :: GYScript 'PlutusV3 + y = scriptFromApi x -scriptFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYScript v +scriptFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYScript v scriptFromApi script = GYScript v script apiHash where v = singPlutusVersion @v @@ -748,19 +773,19 @@ scriptFromApi script = GYScript v script apiHash -- >>> scriptFromCBOR @'PlutusV2 "59212d010000323232323322332233223232323322323232323232323332223332223232323232332232323232323232323233322232323232323233223232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323223232323223232322323253353232323232323232323232323304e3301c4912054687265616420746f6b656e206d697373696e672066726f6d20696e7075742e00330553304d301a50043035500b480094cd4c0e0030854cd4c100034854ccd400454cccccd4028418041808418441804cc140cc0792411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e005007221062106015333333500a1330503301e4911c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e00500710602106110601060221062153333335009105f13304f3301d49011c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d4914043616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f7220666972737420706c617965722773206d6f76652e0033350455052350443332001505948009402cc071401ccc075241124e4654206d757374206265206275726e742e00500621060105f105f221330513301f49011b4e6f74207369676e656420627920666972737420706c617965722e003355073301c50093355073078303d500e330513301f49110436f6d6d6974206d69736d617463682e0033036372466e28008c178004c10c03ccc144cc07d241104d697373656420646561646c696e652e003335047505433502f3039500e500d301e50095333553353332001505d001003106d1533553335001153335003106110621061153335003106110611062153335003106210611061106c106b1330513301f49011357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406d330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d24012d5365636f6e6420706c617965722773207374616b65206d697373696e6720696e2064726177206f75747075742e00330583505f301d5006303a500e13301f4901124e4654206d757374206265206275726e742e0050081330513301f4911357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406b330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d240126596f75206c6f73742c2063616e6e6f742074616b65207374616b652066726f6d2067616d652e00330583505f301d50063332001505948010c0e9403854cd4c0fc0308417c54cccccd40204178417884cc13ccc0752411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d49120466972737420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50053038500c3304f3301d4901215365636f6e6420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50043332001505748010c0e14030cc13ccc07524011357726f6e67206f757470757420646174756d2e003304f3303430415003304100d3304f3332001505a3039500335079001325335001210611061304050033304f3301d491104d697373656420646561646c696e652e003335045505233502d3037500c500a301c50073301d49011a546f6b656e206d697373696e672066726f6d206f75747075742e00330563304e301b50043036500c480084cc138cc07124011b4e6f74207369676e656420627920666972737420706c617965722e003355070301950063075303a500b3304e3301c4914143616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f72207365636f6e6420706c617965722773206d6f76652e00333504450513504333320015058480094024c06d4018cc071241124e4654206d757374206265206275726e742e005005105e22106015335303e50012100113507c4901334d6174636820726573756c7420657870656374656420627574206f757470757420646174756d20686173206e6f7468696e672e001335506e05f306f500115335335506d3355302a1200122533532323304f33033303b002303b0013304f33033303a002303a0013304f33056303800230380013304f33056303700230370013304f33056303f002303f0013304f3232350022235003225335333573466e3c0100081981944cc0e800c0044194c0dc008c0d8008cc13ccc0c8c0d4008c0d4004cc13ccc0d0c0f0008c0f0004cc13ccc158c0f4008c0f4004cc13ccc0d0c108008c108004cc0d0c10c008c10c004c0f4030c0f0cd541bc180c1c00084cd41c4008004400541c14cd4c0ac01084d400488d40048888d402c88d4008888888888888ccd54c0fc4800488d400888894cd4cc1280600104cd42280401801440154214040284c98c81f0cd5ce2481024c660007c13507a491384e6f206f7574707574206174207468697320736372697074206164647265737320686176696e672073616d6520706172616d65746572732e00221533500110022213507e49012145787065637465642065786163746c79206f6e652067616d65206f75747075742e0015335302a00321350012200113507949011347616d6520696e707574206d697373696e672e00133050330483235001222222222222008500130305006480044d400488008cccd5cd19b8735573aa00e9000119910919800801801191919191919191919191919191999ab9a3370e6aae754031200023333333333332222222222221233333333333300100d00c00b00a00900800700600500400300233502502635742a01866a04a04c6ae85402ccd409409cd5d0a805199aa814bae502835742a012666aa052eb940a0d5d0a80419a8128179aba150073335502903075a6ae854018c8c8c8cccd5cd19b8735573aa0049000119a8289919191999ab9a3370e6aae7540092000233505633503a75a6ae854008c0ecd5d09aba2500223263208f013357380c011e0211a0226aae7940044dd50009aba150023232323333573466e1cd55cea80124000466a0b066a074eb4d5d0a801181d9aba135744a004464c6411e0266ae7018023c04234044d55cf280089baa001357426ae8940088c98c822c04cd5ce02e045808448089aab9e5001137540026ae854014cd4095d71aba150043335502902c200135742a006666aa052eb88004d5d0a80118171aba135744a004464c6410e0266ae7016021c04214044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135573ca00226ea8004d5d0a803980f1aba135744a00e464c640f266ae701281e41dccccd5cd19b87500848028848888880188cccd5cd19b87500948020848888880088cccd5cd19b87500a48018848888880148cccd5cd19b87500b480108488888800c8cccd5cd19b87500c480088c8c84888888cc00402001cc134d5d09aba2500f375c6ae8540388cccd5cd19b87500d480008c84888888c01001cc134d5d09aab9e501023263207d33573809c0fa0f60f40f20f00ee0ec26664002a09e605aa00464002606aa00426664002a09c6664002a09c6058a002640026068a002640026068a002260640026666ae68cdc39aab9d500b480008cccc160c8c8c8c8c8c8c8c8c8c8c8c8cccd5cd19b8735573aa016900011999999999983218121aba1500b302435742a0146eb4d5d0a8049bad35742a0106eb4d5d0a8039919191999ab9a3370e6aae75400920002335507a375c6ae854008dd71aba135744a004464c6410a0266ae701582140420c044d55cf280089baa00135742a00c604e6ae854014dd71aba15004375a6ae85400cdd71aba15002375c6ae84d5d128011193190408099ab9c0520810107f135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226aae7940044dd50009aba1500b375c6ae854028cd4060110d5d0a80499a80c1191999ab9a3370ea0029002103111999ab9a3370ea0049001103091999ab9a3370ea0069000103191931903c99ab9c04a079077076075135573a6ea8004d5d09aba2500923263207433573808a0e80e420e626a0e292010350543500135573ca00226ea80044d55cea80109aab9e50011375400226ae8940044d5d1280089aab9e500113754002446a004444444444444a66a666aa604a24002a0484a66a666ae68cdc780700082a82a09a8370008a8368021082a882991a800911100191a80091111111111100291299a8008822899ab9c0020441232230023758002640026aa0c8446666aae7c004941688cd4164c010d5d080118019aba2002065232323333573466e1cd55cea8012400046644246600200600460166ae854008c014d5d09aba2500223263206533573806c0ca0c626aae7940044dd50009191919191999ab9a3370e6aae7540112000233332222123333001005004003002300935742a008666aa010eb9401cd5d0a8019919191999ab9a3370ea0029002119091118010021aba135573ca00646666ae68cdc3a80124004464244460020086eb8d5d09aab9e500423333573466e1d400d20002122200323263206c33573807a0d80d40d20d026aae7540044dd50009aba1500233500a75c6ae84d5d1280111931903319ab9c037066064135744a00226ae8940044d55cf280089baa0011335500175ceb44488c88c008dd5800990009aa83091191999aab9f0022505823350573355059300635573aa004600a6aae794008c010d5d100183189aba1001232323333573466e1cd55cea801240004660b060166ae854008cd4014028d5d09aba250022326320613357380640c20be26aae7940044dd500089119191999ab9a3370ea002900011a82d18029aba135573ca00646666ae68cdc3a801240044a0b4464c640c466ae700cc18818017c4d55cea80089baa001232323333573466e1d400520062321222230040053007357426aae79400c8cccd5cd19b875002480108c848888c008014c024d5d09aab9e500423333573466e1d400d20022321222230010053007357426aae7940148cccd5cd19b875004480008c848888c00c014dd71aba135573ca00c464c640c466ae700cc18818017c1781744d55cea80089baa001232323333573466e1cd55cea80124000466086600a6ae854008dd69aba135744a004464c640bc66ae700bc1781704d55cf280089baa0012323333573466e1cd55cea800a400046eb8d5d09aab9e500223263205c33573805a0b80b426ea80048c8c8c8c8c8cccd5cd19b8750014803084888888800c8cccd5cd19b875002480288488888880108cccd5cd19b875003480208cc8848888888cc004024020dd71aba15005375a6ae84d5d1280291999ab9a3370ea00890031199109111111198010048041bae35742a00e6eb8d5d09aba2500723333573466e1d40152004233221222222233006009008300c35742a0126eb8d5d09aba2500923333573466e1d40192002232122222223007008300d357426aae79402c8cccd5cd19b875007480008c848888888c014020c038d5d09aab9e500c23263206533573806c0ca0c60c40c20c00be0bc0ba26aae7540104d55cf280189aab9e5002135573ca00226ea80048c8c8c8c8cccd5cd19b875001480088ccc15cdd69aba15004375a6ae85400cdd69aba135744a00646666ae68cdc3a80124000460b260106ae84d55cf280311931902f19ab9c02f05e05c05b135573aa00626ae8940044d55cf280089baa001232323333573466e1d4005200223056375c6ae84d55cf280191999ab9a3370ea00490001182c1bae357426aae7940108c98c816ccd5ce01602d82c82c09aab9d50011375400224464646666ae68cdc3a800a40084a04a46666ae68cdc3a8012400446a04e600c6ae84d55cf280211999ab9a3370ea00690001091100111931902e19ab9c02d05c05a059058135573aa00226ea80048c8cccd5cd19b8750014800880dc8cccd5cd19b8750024800080dc8c98c8160cd5ce01482c02b02a89aab9d375400224466a03666a0386a04200406a66a03c6a04200206a640026aa0a64422444a66a00220044426600a004666aa600e2400200a00800246a002446a0044444444444446666a01a4a0b24a0b24a0b24666aa602424002a02246a00244a66a6602c00400826a0ba0062a0b801a264246600244a66a004420062002004a090640026aa0a04422444a66a00226a00644002442666a00a440046008004666aa600e2400200a00800244a66a666ae68cdc79a801110011a800910010180178999ab9a3370e6a004440026a0024400206005e205e446a004446a006446466a00a466a0084a66a666ae68cdc780100081b01a8a801881a901a919a802101a9299a999ab9a3371e00400206c06a2a006206a2a66a00642a66a0044266a004466a004466a004466a00446601a0040024070466a004407046601a00400244407044466a0084070444a66a666ae68cdc380300181d81d0a99a999ab9a3370e00a0040760742660620080022074207420662a66a00242066206644666ae68cdc780100081701691a8009111111111100291a8009111111111100311a8009111111111100411a8009111111111100491a800911100111a8009111111111100511a8009111111111100591a8009111111111100211a8009111111111100191a800911100211a8009111111111100391a800911100091a800911100191a8009111111111100111a800911111111110008919a80199a8021a80480080e99a803280400e89111a801111a801111a802911a801112999a999a8080058030010a99a8008a99a8028999a80700580180388128999a80700580180388128999a8070058018038910919800801801091091980080180109111a801111a801912999a999a8048038020010a99a8018800880f880f080f89109198008018010911191919192999a80310a999a80310a999a80410980224c26006930a999a80390980224c2600693080a08090a999a80390980224c26006930a999a80310980224c260069308098a999a80290808880908080a999a80290a999a803909802a4c26008930a999a803109802a4c2600893080988088a999a803109802a4c26008930a999a802909802a4c2600893080912999a80290a999a80390a999a80390999a8068050010008b0b0b08090a999a80310a999a80310999a8060048010008b0b0b0808880812999a80210a999a80310a999a80310999a8060048010008b0b0b08088a999a80290a999a80290999a8058040010008b0b0b0808080792999a80190a999a80290a999a80290999a8058040010008b0b0b08080a999a80210a999a80210999a8050038010008b0b0b0807880712999a80110a999a80210a999a80210999a8050038010008b0b0b08078a999a80190a999a80190999a8048030010008b0b0b08070806890911180180208911000891a80091111111003911a8009119980a00200100091299a801080088091191999ab9a3370ea0029002100c91999ab9a3370ea0049001100e11999ab9a3370ea0069000100e11931901a99ab9c006035033032031135573a6ea8005241035054310011233333333001005225335333573466e1c008004044040401854cd4ccd5cd19b890020010110101004100522333573466e2000800404404088ccd5cd19b8900200101101022333573466e2400800404004488ccd5cd19b88002001010011225335333573466e2400800404404040044008894cd4ccd5cd19b890020010110101002100112220031222002122200122333573466e1c00800403002c488cdc10010008912999a8010a999a8008805080488048a999a8008804880508048a999a80088048804880509119b8000200113222533500221533500221330050020011009153350012100910095001122533350021533350011007100610061533350011006100710061533350011006100610072333500148905506170657200488104526f636b0048810853636973736f72730012320013330020010050052223232300100532001355027223350014800088d4008894cd4ccd5cd19b8f00200900c00b130070011300600332001355026223350014800088d4008894cd4ccd5cd19b8f00200700b00a100113006003122002122001488100253353355010232323232323333333574800c46666ae68cdc39aab9d5006480008cccd55cfa8031281011999aab9f500625021233335573ea00c4a04446666aae7d40189408c8cccd55cf9aba2500725335533553355335323232323232323232323232323333333574801a46666ae68cdc39aab9d500d480008cccd55cfa8069281a11999aab9f500d25035233335573ea01a4a06c46666aae7d4034940dc8cccd55cfa8069281c11999aab9f500d25039233335573ea01a4a07446666aae7d4034940ec8cccd55cfa8069281e11999aab9f500d2503d233335573ea01a4a07c46666aae7cd5d128071299aa99aa99aa99aa99aa99aa99aa99aa99aa99aa99a98199aba150192135041302b0011503f215335303435742a032426a08460040022a0802a07e42a66a606a6ae85406084d4108c00800454100540fc854cd4c0d4d5d0a80b909a82118010008a8200a81f90a99a981a9aba1501621350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c100d5d0a80390a99a98209aba15007213504c33550480020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501521350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c8c8c8ccccccd5d200191999ab9a3370e6aae75400d2000233335573ea0064a09e46666aae7cd5d128021299a98239aba15005213505200115050250500570562504e0542504d2504d2504d2504d054135573ca00226ea8004d5d0a80390a99a981f9aba15007213504c330380020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501421350423002001150401503f215335303735742a026426a08460040022a0802a07e42a66a606a6ae85404884d4108c00800454100540fc854cd4c0dcd5d0a808909a82118010008a8200a81f90a99a981b9aba1501021350423002001150401503f2503f04604504404304204104003f03e03d03c03b2503303925032250322503225032039135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d55cf280089baa00135742a016426a04c60220022a04842a66a60386ae85402c84d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01a2502c03323333573466e1d400d2002233335573ea00a46a05c03a4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc074940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402884d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01f2502c03323333573466e1d400d2002233335573ea00a46a05c03c4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc080940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402484d409cc0080045409454090940900ac0a80a40a009c9407c094940789407894078940780944d5d1280089aba25001135744a00226aae7940044dd50008009080089a80ea491e446174756d20636f756c646e277420626520646573657269616c697365640022222222222123333333333300100c00b00a009008007006005004003002222212333300100500400300222123300100300212220031222002122200112220031222002122200123232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021280991999aab9f500425014233335573e6ae89401494cd4c02cd5d0a80390a99a99a807119191919191999999aba400623333573466e1d40092002233335573ea00c4a03e46666aae7d4018940808cccd55cfa8031281091999aab9f35744a00e4a66a602e6ae854028854cd4c060d5d0a80510a99a980c9aba1500a21350263330270030020011502415023150222502202902802702623333573466e1d400d2000233335573ea00e4a04046666aae7cd5d128041299a980b9aba150092135023302500115021250210280272501f0250242501d2501d2501d2501d024135573aa00826ae8940044d5d1280089aab9e5001137540026ae85401c84d4060cc05800800454058540549405407006c06894048060940449404494044940440604d5d1280089aab9e50011375400246666666ae900049403494034940348d4038dd68011280680a11919191999999aba400423333573466e1d40092002233335573ea0084a02246666aae7cd5d128029299a98049aba1500621350143017001150122501201901823333573466e1d400d2000233335573ea00a4a02446666aae7cd5d128031299a98051aba1500721350153019001150132501301a019250110170162500f2500f2500f2500f016135573aa00426aae7940044dd500091999999aba40012500b2500b2500b2500b23500c375c0040242446464646666666ae900108cccd5cd19b875002480008cccd55cfa8021280811999aab9f35744a00a4a66a60126ae85401884d404cd404c004540449404406005c8cccd5cd19b875003480088cccd55cfa80291a80928089280880c1280800b00a9280712807128071280700a89aab9d5002135573ca00226ea80044488c00800494ccd4d400488880084d40352411e47616d65206f757470757420646f65736e2774206861766520646174756d0021001213500e49012647616d65206f757470757420646f65736e2774206861766520646174756d20696e6c696e65640011220021221223300100400311221233001003002253353500122335002235007001250062100113500949012d4e6f205075624b65792063726564656e7469616c7320657869737420666f72207468697320616464726573732e002212330010030021212230020031122001212230020032221223330010050040032122300200321223001003123263200333573800200693090008891918008009119801980100100081" -- Just (GYScript "5a2f01c4186061b8197e6a4646d34ec8fd1f3cbdeb67fbb8ab831b25") -scriptFromCBOR :: forall v. SingPlutusVersionI v => Text -> Maybe (GYScript v) +scriptFromCBOR :: forall v. (SingPlutusVersionI v) => Text -> Maybe (GYScript v) scriptFromCBOR = scriptFromCBOR' . encodeUtf8 -- >>> scriptFromCBOR' @'PlutusV2 "59212d010000323232323322332233223232323322323232323232323332223332223232323232332232323232323232323233322232323232323233223232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323223232323223232322323253353232323232323232323232323304e3301c4912054687265616420746f6b656e206d697373696e672066726f6d20696e7075742e00330553304d301a50043035500b480094cd4c0e0030854cd4c100034854ccd400454cccccd4028418041808418441804cc140cc0792411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e005007221062106015333333500a1330503301e4911c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e00500710602106110601060221062153333335009105f13304f3301d49011c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d4914043616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f7220666972737420706c617965722773206d6f76652e0033350455052350443332001505948009402cc071401ccc075241124e4654206d757374206265206275726e742e00500621060105f105f221330513301f49011b4e6f74207369676e656420627920666972737420706c617965722e003355073301c50093355073078303d500e330513301f49110436f6d6d6974206d69736d617463682e0033036372466e28008c178004c10c03ccc144cc07d241104d697373656420646561646c696e652e003335047505433502f3039500e500d301e50095333553353332001505d001003106d1533553335001153335003106110621061153335003106110611062153335003106210611061106c106b1330513301f49011357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406d330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d24012d5365636f6e6420706c617965722773207374616b65206d697373696e6720696e2064726177206f75747075742e00330583505f301d5006303a500e13301f4901124e4654206d757374206265206275726e742e0050081330513301f4911357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406b330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d240126596f75206c6f73742c2063616e6e6f742074616b65207374616b652066726f6d2067616d652e00330583505f301d50063332001505948010c0e9403854cd4c0fc0308417c54cccccd40204178417884cc13ccc0752411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d49120466972737420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50053038500c3304f3301d4901215365636f6e6420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50043332001505748010c0e14030cc13ccc07524011357726f6e67206f757470757420646174756d2e003304f3303430415003304100d3304f3332001505a3039500335079001325335001210611061304050033304f3301d491104d697373656420646561646c696e652e003335045505233502d3037500c500a301c50073301d49011a546f6b656e206d697373696e672066726f6d206f75747075742e00330563304e301b50043036500c480084cc138cc07124011b4e6f74207369676e656420627920666972737420706c617965722e003355070301950063075303a500b3304e3301c4914143616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f72207365636f6e6420706c617965722773206d6f76652e00333504450513504333320015058480094024c06d4018cc071241124e4654206d757374206265206275726e742e005005105e22106015335303e50012100113507c4901334d6174636820726573756c7420657870656374656420627574206f757470757420646174756d20686173206e6f7468696e672e001335506e05f306f500115335335506d3355302a1200122533532323304f33033303b002303b0013304f33033303a002303a0013304f33056303800230380013304f33056303700230370013304f33056303f002303f0013304f3232350022235003225335333573466e3c0100081981944cc0e800c0044194c0dc008c0d8008cc13ccc0c8c0d4008c0d4004cc13ccc0d0c0f0008c0f0004cc13ccc158c0f4008c0f4004cc13ccc0d0c108008c108004cc0d0c10c008c10c004c0f4030c0f0cd541bc180c1c00084cd41c4008004400541c14cd4c0ac01084d400488d40048888d402c88d4008888888888888ccd54c0fc4800488d400888894cd4cc1280600104cd42280401801440154214040284c98c81f0cd5ce2481024c660007c13507a491384e6f206f7574707574206174207468697320736372697074206164647265737320686176696e672073616d6520706172616d65746572732e00221533500110022213507e49012145787065637465642065786163746c79206f6e652067616d65206f75747075742e0015335302a00321350012200113507949011347616d6520696e707574206d697373696e672e00133050330483235001222222222222008500130305006480044d400488008cccd5cd19b8735573aa00e9000119910919800801801191919191919191919191919191999ab9a3370e6aae754031200023333333333332222222222221233333333333300100d00c00b00a00900800700600500400300233502502635742a01866a04a04c6ae85402ccd409409cd5d0a805199aa814bae502835742a012666aa052eb940a0d5d0a80419a8128179aba150073335502903075a6ae854018c8c8c8cccd5cd19b8735573aa0049000119a8289919191999ab9a3370e6aae7540092000233505633503a75a6ae854008c0ecd5d09aba2500223263208f013357380c011e0211a0226aae7940044dd50009aba150023232323333573466e1cd55cea80124000466a0b066a074eb4d5d0a801181d9aba135744a004464c6411e0266ae7018023c04234044d55cf280089baa001357426ae8940088c98c822c04cd5ce02e045808448089aab9e5001137540026ae854014cd4095d71aba150043335502902c200135742a006666aa052eb88004d5d0a80118171aba135744a004464c6410e0266ae7016021c04214044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135573ca00226ea8004d5d0a803980f1aba135744a00e464c640f266ae701281e41dccccd5cd19b87500848028848888880188cccd5cd19b87500948020848888880088cccd5cd19b87500a48018848888880148cccd5cd19b87500b480108488888800c8cccd5cd19b87500c480088c8c84888888cc00402001cc134d5d09aba2500f375c6ae8540388cccd5cd19b87500d480008c84888888c01001cc134d5d09aab9e501023263207d33573809c0fa0f60f40f20f00ee0ec26664002a09e605aa00464002606aa00426664002a09c6664002a09c6058a002640026068a002640026068a002260640026666ae68cdc39aab9d500b480008cccc160c8c8c8c8c8c8c8c8c8c8c8c8cccd5cd19b8735573aa016900011999999999983218121aba1500b302435742a0146eb4d5d0a8049bad35742a0106eb4d5d0a8039919191999ab9a3370e6aae75400920002335507a375c6ae854008dd71aba135744a004464c6410a0266ae701582140420c044d55cf280089baa00135742a00c604e6ae854014dd71aba15004375a6ae85400cdd71aba15002375c6ae84d5d128011193190408099ab9c0520810107f135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226aae7940044dd50009aba1500b375c6ae854028cd4060110d5d0a80499a80c1191999ab9a3370ea0029002103111999ab9a3370ea0049001103091999ab9a3370ea0069000103191931903c99ab9c04a079077076075135573a6ea8004d5d09aba2500923263207433573808a0e80e420e626a0e292010350543500135573ca00226ea80044d55cea80109aab9e50011375400226ae8940044d5d1280089aab9e500113754002446a004444444444444a66a666aa604a24002a0484a66a666ae68cdc780700082a82a09a8370008a8368021082a882991a800911100191a80091111111111100291299a8008822899ab9c0020441232230023758002640026aa0c8446666aae7c004941688cd4164c010d5d080118019aba2002065232323333573466e1cd55cea8012400046644246600200600460166ae854008c014d5d09aba2500223263206533573806c0ca0c626aae7940044dd50009191919191999ab9a3370e6aae7540112000233332222123333001005004003002300935742a008666aa010eb9401cd5d0a8019919191999ab9a3370ea0029002119091118010021aba135573ca00646666ae68cdc3a80124004464244460020086eb8d5d09aab9e500423333573466e1d400d20002122200323263206c33573807a0d80d40d20d026aae7540044dd50009aba1500233500a75c6ae84d5d1280111931903319ab9c037066064135744a00226ae8940044d55cf280089baa0011335500175ceb44488c88c008dd5800990009aa83091191999aab9f0022505823350573355059300635573aa004600a6aae794008c010d5d100183189aba1001232323333573466e1cd55cea801240004660b060166ae854008cd4014028d5d09aba250022326320613357380640c20be26aae7940044dd500089119191999ab9a3370ea002900011a82d18029aba135573ca00646666ae68cdc3a801240044a0b4464c640c466ae700cc18818017c4d55cea80089baa001232323333573466e1d400520062321222230040053007357426aae79400c8cccd5cd19b875002480108c848888c008014c024d5d09aab9e500423333573466e1d400d20022321222230010053007357426aae7940148cccd5cd19b875004480008c848888c00c014dd71aba135573ca00c464c640c466ae700cc18818017c1781744d55cea80089baa001232323333573466e1cd55cea80124000466086600a6ae854008dd69aba135744a004464c640bc66ae700bc1781704d55cf280089baa0012323333573466e1cd55cea800a400046eb8d5d09aab9e500223263205c33573805a0b80b426ea80048c8c8c8c8c8cccd5cd19b8750014803084888888800c8cccd5cd19b875002480288488888880108cccd5cd19b875003480208cc8848888888cc004024020dd71aba15005375a6ae84d5d1280291999ab9a3370ea00890031199109111111198010048041bae35742a00e6eb8d5d09aba2500723333573466e1d40152004233221222222233006009008300c35742a0126eb8d5d09aba2500923333573466e1d40192002232122222223007008300d357426aae79402c8cccd5cd19b875007480008c848888888c014020c038d5d09aab9e500c23263206533573806c0ca0c60c40c20c00be0bc0ba26aae7540104d55cf280189aab9e5002135573ca00226ea80048c8c8c8c8cccd5cd19b875001480088ccc15cdd69aba15004375a6ae85400cdd69aba135744a00646666ae68cdc3a80124000460b260106ae84d55cf280311931902f19ab9c02f05e05c05b135573aa00626ae8940044d55cf280089baa001232323333573466e1d4005200223056375c6ae84d55cf280191999ab9a3370ea00490001182c1bae357426aae7940108c98c816ccd5ce01602d82c82c09aab9d50011375400224464646666ae68cdc3a800a40084a04a46666ae68cdc3a8012400446a04e600c6ae84d55cf280211999ab9a3370ea00690001091100111931902e19ab9c02d05c05a059058135573aa00226ea80048c8cccd5cd19b8750014800880dc8cccd5cd19b8750024800080dc8c98c8160cd5ce01482c02b02a89aab9d375400224466a03666a0386a04200406a66a03c6a04200206a640026aa0a64422444a66a00220044426600a004666aa600e2400200a00800246a002446a0044444444444446666a01a4a0b24a0b24a0b24666aa602424002a02246a00244a66a6602c00400826a0ba0062a0b801a264246600244a66a004420062002004a090640026aa0a04422444a66a00226a00644002442666a00a440046008004666aa600e2400200a00800244a66a666ae68cdc79a801110011a800910010180178999ab9a3370e6a004440026a0024400206005e205e446a004446a006446466a00a466a0084a66a666ae68cdc780100081b01a8a801881a901a919a802101a9299a999ab9a3371e00400206c06a2a006206a2a66a00642a66a0044266a004466a004466a004466a00446601a0040024070466a004407046601a00400244407044466a0084070444a66a666ae68cdc380300181d81d0a99a999ab9a3370e00a0040760742660620080022074207420662a66a00242066206644666ae68cdc780100081701691a8009111111111100291a8009111111111100311a8009111111111100411a8009111111111100491a800911100111a8009111111111100511a8009111111111100591a8009111111111100211a8009111111111100191a800911100211a8009111111111100391a800911100091a800911100191a8009111111111100111a800911111111110008919a80199a8021a80480080e99a803280400e89111a801111a801111a802911a801112999a999a8080058030010a99a8008a99a8028999a80700580180388128999a80700580180388128999a8070058018038910919800801801091091980080180109111a801111a801912999a999a8048038020010a99a8018800880f880f080f89109198008018010911191919192999a80310a999a80310a999a80410980224c26006930a999a80390980224c2600693080a08090a999a80390980224c26006930a999a80310980224c260069308098a999a80290808880908080a999a80290a999a803909802a4c26008930a999a803109802a4c2600893080988088a999a803109802a4c26008930a999a802909802a4c2600893080912999a80290a999a80390a999a80390999a8068050010008b0b0b08090a999a80310a999a80310999a8060048010008b0b0b0808880812999a80210a999a80310a999a80310999a8060048010008b0b0b08088a999a80290a999a80290999a8058040010008b0b0b0808080792999a80190a999a80290a999a80290999a8058040010008b0b0b08080a999a80210a999a80210999a8050038010008b0b0b0807880712999a80110a999a80210a999a80210999a8050038010008b0b0b08078a999a80190a999a80190999a8048030010008b0b0b08070806890911180180208911000891a80091111111003911a8009119980a00200100091299a801080088091191999ab9a3370ea0029002100c91999ab9a3370ea0049001100e11999ab9a3370ea0069000100e11931901a99ab9c006035033032031135573a6ea8005241035054310011233333333001005225335333573466e1c008004044040401854cd4ccd5cd19b890020010110101004100522333573466e2000800404404088ccd5cd19b8900200101101022333573466e2400800404004488ccd5cd19b88002001010011225335333573466e2400800404404040044008894cd4ccd5cd19b890020010110101002100112220031222002122200122333573466e1c00800403002c488cdc10010008912999a8010a999a8008805080488048a999a8008804880508048a999a80088048804880509119b8000200113222533500221533500221330050020011009153350012100910095001122533350021533350011007100610061533350011006100710061533350011006100610072333500148905506170657200488104526f636b0048810853636973736f72730012320013330020010050052223232300100532001355027223350014800088d4008894cd4ccd5cd19b8f00200900c00b130070011300600332001355026223350014800088d4008894cd4ccd5cd19b8f00200700b00a100113006003122002122001488100253353355010232323232323333333574800c46666ae68cdc39aab9d5006480008cccd55cfa8031281011999aab9f500625021233335573ea00c4a04446666aae7d40189408c8cccd55cf9aba2500725335533553355335323232323232323232323232323333333574801a46666ae68cdc39aab9d500d480008cccd55cfa8069281a11999aab9f500d25035233335573ea01a4a06c46666aae7d4034940dc8cccd55cfa8069281c11999aab9f500d25039233335573ea01a4a07446666aae7d4034940ec8cccd55cfa8069281e11999aab9f500d2503d233335573ea01a4a07c46666aae7cd5d128071299aa99aa99aa99aa99aa99aa99aa99aa99aa99aa99a98199aba150192135041302b0011503f215335303435742a032426a08460040022a0802a07e42a66a606a6ae85406084d4108c00800454100540fc854cd4c0d4d5d0a80b909a82118010008a8200a81f90a99a981a9aba1501621350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c100d5d0a80390a99a98209aba15007213504c33550480020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501521350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c8c8c8ccccccd5d200191999ab9a3370e6aae75400d2000233335573ea0064a09e46666aae7cd5d128021299a98239aba15005213505200115050250500570562504e0542504d2504d2504d2504d054135573ca00226ea8004d5d0a80390a99a981f9aba15007213504c330380020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501421350423002001150401503f215335303735742a026426a08460040022a0802a07e42a66a606a6ae85404884d4108c00800454100540fc854cd4c0dcd5d0a808909a82118010008a8200a81f90a99a981b9aba1501021350423002001150401503f2503f04604504404304204104003f03e03d03c03b2503303925032250322503225032039135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d55cf280089baa00135742a016426a04c60220022a04842a66a60386ae85402c84d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01a2502c03323333573466e1d400d2002233335573ea00a46a05c03a4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc074940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402884d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01f2502c03323333573466e1d400d2002233335573ea00a46a05c03c4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc080940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402484d409cc0080045409454090940900ac0a80a40a009c9407c094940789407894078940780944d5d1280089aba25001135744a00226aae7940044dd50008009080089a80ea491e446174756d20636f756c646e277420626520646573657269616c697365640022222222222123333333333300100c00b00a009008007006005004003002222212333300100500400300222123300100300212220031222002122200112220031222002122200123232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021280991999aab9f500425014233335573e6ae89401494cd4c02cd5d0a80390a99a99a807119191919191999999aba400623333573466e1d40092002233335573ea00c4a03e46666aae7d4018940808cccd55cfa8031281091999aab9f35744a00e4a66a602e6ae854028854cd4c060d5d0a80510a99a980c9aba1500a21350263330270030020011502415023150222502202902802702623333573466e1d400d2000233335573ea00e4a04046666aae7cd5d128041299a980b9aba150092135023302500115021250210280272501f0250242501d2501d2501d2501d024135573aa00826ae8940044d5d1280089aab9e5001137540026ae85401c84d4060cc05800800454058540549405407006c06894048060940449404494044940440604d5d1280089aab9e50011375400246666666ae900049403494034940348d4038dd68011280680a11919191999999aba400423333573466e1d40092002233335573ea0084a02246666aae7cd5d128029299a98049aba1500621350143017001150122501201901823333573466e1d400d2000233335573ea00a4a02446666aae7cd5d128031299a98051aba1500721350153019001150132501301a019250110170162500f2500f2500f2500f016135573aa00426aae7940044dd500091999999aba40012500b2500b2500b2500b23500c375c0040242446464646666666ae900108cccd5cd19b875002480008cccd55cfa8021280811999aab9f35744a00a4a66a60126ae85401884d404cd404c004540449404406005c8cccd5cd19b875003480088cccd55cfa80291a80928089280880c1280800b00a9280712807128071280700a89aab9d5002135573ca00226ea80044488c00800494ccd4d400488880084d40352411e47616d65206f757470757420646f65736e2774206861766520646174756d0021001213500e49012647616d65206f757470757420646f65736e2774206861766520646174756d20696e6c696e65640011220021221223300100400311221233001003002253353500122335002235007001250062100113500949012d4e6f205075624b65792063726564656e7469616c7320657869737420666f72207468697320616464726573732e002212330010030021212230020031122001212230020032221223330010050040032122300200321223001003123263200333573800200693090008891918008009119801980100100081" -- Just (GYScript "5a2f01c4186061b8197e6a4646d34ec8fd1f3cbdeb67fbb8ab831b25") -scriptFromCBOR' :: forall v. SingPlutusVersionI v => ByteString -> Maybe (GYScript v) +scriptFromCBOR' :: forall v. (SingPlutusVersionI v) => ByteString -> Maybe (GYScript v) scriptFromCBOR' b = do - bs <- rightToMaybe (BS16.decode b) - case singPlutusVersion @v of - SingPlutusV1 -> fmap scriptFromApi $ rightToMaybe $ flip Api.deserialiseFromRawBytes bs $ Api.AsPlutusScript $ Api.proxyToAsType $ Proxy @(PlutusVersionToApi v) - SingPlutusV2 -> fmap scriptFromApi $ rightToMaybe $ flip Api.deserialiseFromRawBytes bs $ Api.AsPlutusScript $ Api.proxyToAsType $ Proxy @(PlutusVersionToApi v) - SingPlutusV3 -> fmap scriptFromApi $ rightToMaybe $ flip Api.deserialiseFromRawBytes bs $ Api.AsPlutusScript $ Api.proxyToAsType $ Proxy @(PlutusVersionToApi v) + bs <- rightToMaybe (BS16.decode b) + case singPlutusVersion @v of + SingPlutusV1 -> fmap scriptFromApi $ rightToMaybe $ flip Api.deserialiseFromRawBytes bs $ Api.AsPlutusScript $ Api.proxyToAsType $ Proxy @(PlutusVersionToApi v) + SingPlutusV2 -> fmap scriptFromApi $ rightToMaybe $ flip Api.deserialiseFromRawBytes bs $ Api.AsPlutusScript $ Api.proxyToAsType $ Proxy @(PlutusVersionToApi v) + SingPlutusV3 -> fmap scriptFromApi $ rightToMaybe $ flip Api.deserialiseFromRawBytes bs $ Api.AsPlutusScript $ Api.proxyToAsType $ Proxy @(PlutusVersionToApi v) scriptPlutusHash :: GYScript v -> PlutusV1.ScriptHash scriptPlutusHash = apiHashToPlutus . scriptApiHash @@ -771,98 +796,97 @@ someScriptPlutusHash (Some s) = scriptPlutusHash s scriptApiHash :: GYScript v -> Api.ScriptHash scriptApiHash (GYScript _ _ ah) = ah -scriptToApiPlutusScriptWitness - :: GYScript v - -> Api.S.ScriptDatum ctx - -> Api.ScriptRedeemer - -> Api.ExecutionUnits - -> Api.ScriptWitness ctx ApiEra +scriptToApiPlutusScriptWitness :: + GYScript v -> + Api.S.ScriptDatum ctx -> + Api.ScriptRedeemer -> + Api.ExecutionUnits -> + Api.ScriptWitness ctx ApiEra scriptToApiPlutusScriptWitness (GYScript v api _) = case v of - SingPlutusV1 -> Api.PlutusScriptWitness - Api.PlutusScriptV1InConway - Api.PlutusScriptV1 - (Api.S.PScript api) - SingPlutusV2 -> Api.PlutusScriptWitness - Api.PlutusScriptV2InConway - Api.PlutusScriptV2 - (Api.S.PScript api) - SingPlutusV3 -> Api.PlutusScriptWitness - Api.PlutusScriptV3InConway - Api.PlutusScriptV3 - (Api.S.PScript api) - -referenceScriptToApiPlutusScriptWitness - :: (VersionIsGreaterOrEqual v 'PlutusV2) => GYTxOutRef - -> GYScript v - -> Api.S.ScriptDatum witctx - -> Api.S.ScriptRedeemer - -> Api.S.ExecutionUnits - -> Api.S.ScriptWitness witctx ApiEra + SingPlutusV1 -> + Api.PlutusScriptWitness + Api.PlutusScriptV1InConway + Api.PlutusScriptV1 + (Api.S.PScript api) + SingPlutusV2 -> + Api.PlutusScriptWitness + Api.PlutusScriptV2InConway + Api.PlutusScriptV2 + (Api.S.PScript api) + SingPlutusV3 -> + Api.PlutusScriptWitness + Api.PlutusScriptV3InConway + Api.PlutusScriptV3 + (Api.S.PScript api) + +referenceScriptToApiPlutusScriptWitness :: + (VersionIsGreaterOrEqual v 'PlutusV2) => + GYTxOutRef -> + GYScript v -> + Api.S.ScriptDatum witctx -> + Api.S.ScriptRedeemer -> + Api.S.ExecutionUnits -> + Api.S.ScriptWitness witctx ApiEra referenceScriptToApiPlutusScriptWitness r s = let apiV = singPlutusVersionToApi (scriptVersion s) - in - Api.PlutusScriptWitness - (case apiV of Api.PlutusScriptV1 -> Api.PlutusScriptV1InConway; Api.PlutusScriptV2 -> Api.PlutusScriptV2InConway; Api.PlutusScriptV3 -> Api.PlutusScriptV3InConway) - apiV - (Api.S.PReferenceScript (txOutRefToApi r) (Just (scriptApiHash s))) + in Api.PlutusScriptWitness + (case apiV of Api.PlutusScriptV1 -> Api.PlutusScriptV1InConway; Api.PlutusScriptV2 -> Api.PlutusScriptV2InConway; Api.PlutusScriptV3 -> Api.PlutusScriptV3InConway) + apiV + (Api.S.PReferenceScript (txOutRefToApi r) (Just (scriptApiHash s))) scriptSize :: GYAnyScript -> Int -scriptSize s = anyScriptToApiScriptInEra s & Api.toShelleyScript & originalBytesSize -- Maybe we could have done it a simpler way but this is how it script size is actually determined inside ledger codebase. +scriptSize s = anyScriptToApiScriptInEra s & Api.toShelleyScript & originalBytesSize -- Maybe we could have done it a simpler way but this is how it script size is actually determined inside ledger codebase. -- | Writes a script to a file. --- writeScript :: forall v. FilePath -> GYScript v -> IO () writeScript = writeScriptCore "Script" -- | Reads a script from a file. --- -readScript :: forall v. SingPlutusVersionI v => FilePath -> IO (GYScript v) +readScript :: forall v. (SingPlutusVersionI v) => FilePath -> IO (GYScript v) readScript file = case singPlutusVersion @v of - SingPlutusV1 -> do - e <- Api.readFileTextEnvelope (Api.AsPlutusScript Api.AsPlutusScriptV1) (Api.File file) - case e of - Left (err :: Api.FileError Api.TextEnvelopeError) -> throwIO $ userError $ show err - Right s -> return $ scriptFromApi s - - SingPlutusV2 -> do - e <- Api.readFileTextEnvelope (Api.AsPlutusScript Api.AsPlutusScriptV2) (Api.File file) - case e of - Left (err :: Api.FileError Api.TextEnvelopeError) -> throwIO $ userError $ show err - Right s -> return $ scriptFromApi s - - SingPlutusV3 -> do - e <- Api.readFileTextEnvelope (Api.AsPlutusScript Api.AsPlutusScriptV3) (Api.File file) - case e of - Left (err :: Api.FileError Api.TextEnvelopeError) -> throwIO $ userError $ show err - Right s -> return $ scriptFromApi s + SingPlutusV1 -> do + e <- Api.readFileTextEnvelope (Api.AsPlutusScript Api.AsPlutusScriptV1) (Api.File file) + case e of + Left (err :: Api.FileError Api.TextEnvelopeError) -> throwIO $ userError $ show err + Right s -> return $ scriptFromApi s + SingPlutusV2 -> do + e <- Api.readFileTextEnvelope (Api.AsPlutusScript Api.AsPlutusScriptV2) (Api.File file) + case e of + Left (err :: Api.FileError Api.TextEnvelopeError) -> throwIO $ userError $ show err + Right s -> return $ scriptFromApi s + SingPlutusV3 -> do + e <- Api.readFileTextEnvelope (Api.AsPlutusScript Api.AsPlutusScriptV3) (Api.File file) + case e of + Left (err :: Api.FileError Api.TextEnvelopeError) -> throwIO $ userError $ show err + Right s -> return $ scriptFromApi s writeScriptCore :: forall v. Api.S.TextEnvelopeDescr -> FilePath -> GYScript v -> IO () writeScriptCore desc file s = do - e <- case scriptVersion @v s of - SingPlutusV1 -> Api.writeFileTextEnvelope (Api.File file) (Just desc) $ scriptToApi s - SingPlutusV2 -> Api.writeFileTextEnvelope (Api.File file) (Just desc) $ scriptToApi s - SingPlutusV3 -> Api.writeFileTextEnvelope (Api.File file) (Just desc) $ scriptToApi s - case e of - Left (err :: Api.FileError ()) -> throwIO $ userError $ show err - Right () -> return () + e <- case scriptVersion @v s of + SingPlutusV1 -> Api.writeFileTextEnvelope (Api.File file) (Just desc) $ scriptToApi s + SingPlutusV2 -> Api.writeFileTextEnvelope (Api.File file) (Just desc) $ scriptToApi s + SingPlutusV3 -> Api.writeFileTextEnvelope (Api.File file) (Just desc) $ scriptToApi s + case e of + Left (err :: Api.FileError ()) -> throwIO $ userError $ show err + Right () -> return () -- | Type encapsulating both simple and plutus scripts. data GYAnyScript where - GYSimpleScript :: !GYSimpleScript -> GYAnyScript - GYPlutusScript :: forall v. !(GYScript v) -> GYAnyScript + GYSimpleScript :: !GYSimpleScript -> GYAnyScript + GYPlutusScript :: forall v. !(GYScript v) -> GYAnyScript deriving instance Show GYAnyScript instance Eq GYAnyScript where GYSimpleScript s1 == GYSimpleScript s2 = s1 == s2 GYPlutusScript s1 == GYPlutusScript s2 = defaultEq s1 s2 - _ == _ = False + _ == _ = False instance Ord GYAnyScript where compare (GYSimpleScript s1) (GYSimpleScript s2) = compare s1 s2 - compare (GYSimpleScript _) (GYPlutusScript _) = LT + compare (GYSimpleScript _) (GYPlutusScript _) = LT compare (GYPlutusScript s1) (GYPlutusScript s2) = defaultCompare s1 s2 - compare (GYPlutusScript _) (GYSimpleScript _) = GT + compare (GYPlutusScript _) (GYSimpleScript _) = GT hashAnyScript :: GYAnyScript -> GYScriptHash hashAnyScript (GYSimpleScript s) = hashSimpleScript s @@ -878,5 +902,4 @@ anyScriptToApiScriptInEra (GYPlutusScript s@(GYScript v _ _)) = Api.ScriptInEra scriptToApiScript :: GYScript v -> Api.Script (PlutusVersionToApi v) scriptToApiScript (GYScript v' api _) = Api.PlutusScript (singPlutusVersionToApi v') api - anyScriptToApiScriptInEra (GYSimpleScript s) = Api.ScriptInEra Api.SimpleScriptInConway (Api.SimpleScript $ simpleScriptToApi s) diff --git a/src/GeniusYield/Types/Script/ScriptHash.hs b/src/GeniusYield/Types/Script/ScriptHash.hs index 711a476c..7a5e66e2 100644 --- a/src/GeniusYield/Types/Script/ScriptHash.hs +++ b/src/GeniusYield/Types/Script/ScriptHash.hs @@ -1,60 +1,60 @@ -{-| +{- | Module : GeniusYield.Types.Script.ScriptHash Copyright : (c) 2024 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Script.ScriptHash ( - GYScriptHash, - scriptHashFromApi, - scriptHashToApi, - scriptHashToLedger, - scriptHashFromLedger, - apiHashToPlutus, - scriptHashToPlutus, + GYScriptHash, + scriptHashFromApi, + scriptHashToApi, + scriptHashToLedger, + scriptHashFromLedger, + apiHashToPlutus, + scriptHashToPlutus, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Ledger as Ledger -import qualified Cardano.Api.Script as Api -import qualified Cardano.Ledger.Hashes as Ledger -import GeniusYield.Imports -import qualified PlutusLedgerApi.V1 as PlutusV1 -import qualified PlutusTx.Builtins as PlutusTx -import qualified Text.Printf as Printf -import qualified Web.HttpApiData as Web +import Cardano.Api qualified as Api +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Script qualified as Api +import Cardano.Ledger.Hashes qualified as Ledger +import GeniusYield.Imports +import PlutusLedgerApi.V1 qualified as PlutusV1 +import PlutusTx.Builtins qualified as PlutusTx +import Text.Printf qualified as Printf +import Web.HttpApiData qualified as Web --- $setup --- --- >>> import GeniusYield.Imports +{- $setup + +>>> import GeniusYield.Imports +-} newtype GYScriptHash = GYScriptHash Api.ScriptHash deriving stock (Show, Eq, Ord) deriving newtype (FromJSON, ToJSON) --- | --- --- >>> "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYScriptHash --- GYScriptHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" --- +{- | + +>>> "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYScriptHash +GYScriptHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" +-} instance IsString GYScriptHash where - fromString = GYScriptHash . fromString + fromString = GYScriptHash . fromString --- | --- --- >>> printf "%s" ("cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYScriptHash) --- cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0 --- +{- | + +>>> printf "%s" ("cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" :: GYScriptHash) +cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0 +-} instance Printf.PrintfArg GYScriptHash where - formatArg (GYScriptHash h) = formatArg $ init $ tail $ show h + formatArg (GYScriptHash h) = formatArg $ init $ tail $ show h -- >>> Web.toUrlPiece (GYScriptHash "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0") -- "cabdd19b58d4299fde05b53c2c0baf978bf9ade734b490fc0cc8b7d0" -- instance Web.ToHttpApiData GYScriptHash where - toUrlPiece = Api.serialiseToRawBytesHexText . scriptHashToApi + toUrlPiece = Api.serialiseToRawBytesHexText . scriptHashToApi scriptHashToApi :: GYScriptHash -> Api.ScriptHash scriptHashToApi = coerce diff --git a/src/GeniusYield/Types/Script/SimpleScript.hs b/src/GeniusYield/Types/Script/SimpleScript.hs index 2357d048..c70ad6d2 100644 --- a/src/GeniusYield/Types/Script/SimpleScript.hs +++ b/src/GeniusYield/Types/Script/SimpleScript.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.Types.Script.SimpleScript Description : Simple scripts API Copyright : (c) 2024 GYELD GMBH @@ -23,29 +23,37 @@ module GeniusYield.Types.Script.SimpleScript ( simpleScriptFromJSON, ) where -import qualified Cardano.Api as Api -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as BS16 -import Data.Foldable (foldMap') -import qualified Data.Set as Set -import GeniusYield.Imports -import GeniusYield.ReadJSON (readJSON) -import GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash, - paymentKeyHashFromApi, - paymentKeyHashToApi) -import GeniusYield.Types.Script.ScriptHash (GYScriptHash, - scriptHashFromApi) -import GeniusYield.Types.Slot (GYSlot, slotFromApi, - slotToApi) - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> --- >>> import GeniusYield.Types --- >>> import Data.Set qualified as Set +import Cardano.Api qualified as Api +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Base16 qualified as BS16 +import Data.Foldable (foldMap') +import Data.Set qualified as Set +import GeniusYield.Imports +import GeniusYield.ReadJSON (readJSON) +import GeniusYield.Types.PaymentKeyHash ( + GYPaymentKeyHash, + paymentKeyHashFromApi, + paymentKeyHashToApi, + ) +import GeniusYield.Types.Script.ScriptHash ( + GYScriptHash, + scriptHashFromApi, + ) +import GeniusYield.Types.Slot ( + GYSlot, + slotFromApi, + slotToApi, + ) + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> +>>> import GeniusYield.Types +>>> import Data.Set qualified as Set +-} -- | A simple (aka native / timelock) script that can be used in a transaction. data GYSimpleScript @@ -59,21 +67,21 @@ data GYSimpleScript simpleScriptToApi :: GYSimpleScript -> Api.SimpleScript simpleScriptToApi s = case s of - RequireSignature pkh -> Api.RequireSignature $ paymentKeyHashToApi pkh + RequireSignature pkh -> Api.RequireSignature $ paymentKeyHashToApi pkh RequireTimeBefore slot -> Api.RequireTimeBefore $ slotToApi slot - RequireTimeAfter slot -> Api.RequireTimeAfter $ slotToApi slot - RequireAllOf ss -> Api.RequireAllOf $ map simpleScriptToApi ss - RequireAnyOf ss -> Api.RequireAnyOf $ map simpleScriptToApi ss - RequireMOf m ss -> Api.RequireMOf m $ map simpleScriptToApi ss + RequireTimeAfter slot -> Api.RequireTimeAfter $ slotToApi slot + RequireAllOf ss -> Api.RequireAllOf $ map simpleScriptToApi ss + RequireAnyOf ss -> Api.RequireAnyOf $ map simpleScriptToApi ss + RequireMOf m ss -> Api.RequireMOf m $ map simpleScriptToApi ss simpleScriptFromApi :: Api.SimpleScript -> GYSimpleScript simpleScriptFromApi s = case s of - Api.RequireSignature pkh -> RequireSignature $ paymentKeyHashFromApi pkh + Api.RequireSignature pkh -> RequireSignature $ paymentKeyHashFromApi pkh Api.RequireTimeBefore slot -> RequireTimeBefore $ slotFromApi slot - Api.RequireTimeAfter slot -> RequireTimeAfter $ slotFromApi slot - Api.RequireAllOf ss -> RequireAllOf $ map simpleScriptFromApi ss - Api.RequireAnyOf ss -> RequireAnyOf $ map simpleScriptFromApi ss - Api.RequireMOf m ss -> RequireMOf m $ map simpleScriptFromApi ss + Api.RequireTimeAfter slot -> RequireTimeAfter $ slotFromApi slot + Api.RequireAllOf ss -> RequireAllOf $ map simpleScriptFromApi ss + Api.RequireAnyOf ss -> RequireAnyOf $ map simpleScriptFromApi ss + Api.RequireMOf m ss -> RequireMOf m $ map simpleScriptFromApi ss instance ToJSON GYSimpleScript where toJSON = toJSON . simpleScriptToApi @@ -85,17 +93,18 @@ instance FromJSON GYSimpleScript where readSimpleScript :: FilePath -> IO GYSimpleScript readSimpleScript = readJSON --- | Get the total number of unique `GYPaymentKeyHash` mentioned in a 'GYSimpleScript'. --- --- This is useful for estimating the number of signatures required for a transaction. --- --- >>> reqSigA = RequireSignature "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38a" --- >>> reqSigB = RequireSignature "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38b" --- >>> reqSigC = RequireSignature "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38c" --- >>> reqSigD = RequireSignature "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" --- >>> reqSigE = RequireSignature "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38e" --- >>> Set.size $ getTotalKeysInSimpleScript $ RequireMOf 2 [RequireAllOf [reqSigA, reqSigB, reqSigC], RequireAnyOf [reqSigA, reqSigD], reqSigE] --- 5 +{- | Get the total number of unique `GYPaymentKeyHash` mentioned in a 'GYSimpleScript'. + +This is useful for estimating the number of signatures required for a transaction. + +>>> reqSigA = RequireSignature "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38a" +>>> reqSigB = RequireSignature "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38b" +>>> reqSigC = RequireSignature "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38c" +>>> reqSigD = RequireSignature "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" +>>> reqSigE = RequireSignature "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38e" +>>> Set.size $ getTotalKeysInSimpleScript $ RequireMOf 2 [RequireAllOf [reqSigA, reqSigB, reqSigC], RequireAnyOf [reqSigA, reqSigD], reqSigE] +5 +-} getTotalKeysInSimpleScript :: GYSimpleScript -> Set GYPaymentKeyHash getTotalKeysInSimpleScript = \case RequireSignature pkh -> Set.singleton pkh @@ -104,8 +113,8 @@ getTotalKeysInSimpleScript = \case RequireAllOf ss -> f ss RequireAnyOf ss -> f ss RequireMOf _ ss -> f ss - where - f = foldMap' getTotalKeysInSimpleScript + where + f = foldMap' getTotalKeysInSimpleScript hashSimpleScript :: GYSimpleScript -> GYScriptHash hashSimpleScript = scriptHashFromApi . hashSimpleScript' @@ -120,9 +129,9 @@ simpleScriptFromCBOR = simpleScriptFromCBOR' . encodeUtf8 -- FIXME: Need to test this. simpleScriptFromCBOR' :: ByteString -> Maybe GYSimpleScript simpleScriptFromCBOR' b = do - bs <- rightToMaybe (BS16.decode b) - Api.SimpleScript s <- rightToMaybe $ Api.deserialiseFromCBOR (Api.AsScript Api.AsSimpleScript) bs - Just $ simpleScriptFromApi s + bs <- rightToMaybe (BS16.decode b) + Api.SimpleScript s <- rightToMaybe $ Api.deserialiseFromCBOR (Api.AsScript Api.AsSimpleScript) bs + Just $ simpleScriptFromApi s simpleScriptFromJSON :: Aeson.Value -> Maybe GYSimpleScript simpleScriptFromJSON = Aeson.parseMaybe parseJSON diff --git a/src/GeniusYield/Types/Slot.hs b/src/GeniusYield/Types/Slot.hs index 59552e2b..f239baf0 100644 --- a/src/GeniusYield/Types/Slot.hs +++ b/src/GeniusYield/Types/Slot.hs @@ -1,35 +1,35 @@ -{-| +{- | Module : GeniusYield.Types.Slot Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Slot ( - GYSlot, - slotToApi, - slotFromApi, - advanceSlot, - unsafeAdvanceSlot, - slotToInteger, - slotFromInteger, - slotFromWord64, - unsafeSlotFromInteger + GYSlot, + slotToApi, + slotFromApi, + advanceSlot, + unsafeAdvanceSlot, + slotToInteger, + slotFromInteger, + slotFromWord64, + unsafeSlotFromInteger, ) where -import Data.Word (Word64) -import GeniusYield.Imports +import Data.Word (Word64) +import GeniusYield.Imports + +import Cardano.Api qualified as Api +import Data.Swagger qualified as Swagger +import Text.Printf qualified as Printf +import Web.HttpApiData (FromHttpApiData, ToHttpApiData) -import qualified Cardano.Api as Api -import qualified Data.Swagger as Swagger -import qualified Text.Printf as Printf -import Web.HttpApiData (FromHttpApiData, ToHttpApiData) +{- $setup --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +-} -- >>> Aeson.fromJSON @GYSlot $ Aeson.Number 420000000000000000000000000000 -- Error "parsing Word64 failed, value is either floating or will cause over or underflow 4.2e29" @@ -38,7 +38,7 @@ newtype GYSlot = GYSlot Word64 deriving newtype (Swagger.ToParamSchema, Swagger.ToSchema, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData) instance Printf.PrintfArg GYSlot where - formatArg (GYSlot n) = Printf.formatArg (show n) + formatArg (GYSlot n) = Printf.formatArg (show n) slotToApi :: GYSlot -> Api.SlotNo slotToApi = coerce @@ -51,9 +51,9 @@ slotToInteger = coerce (toInteger @Word64) slotFromInteger :: Integer -> Maybe GYSlot slotFromInteger s - | s > toInteger (maxBound :: Word64) = Nothing - | s < toInteger (minBound :: Word64) = Nothing - | otherwise = Just . GYSlot $ fromInteger s + | s > toInteger (maxBound :: Word64) = Nothing + | s < toInteger (minBound :: Word64) = Nothing + | otherwise = Just . GYSlot $ fromInteger s slotFromWord64 :: Word64 -> GYSlot slotFromWord64 = GYSlot @@ -61,8 +61,8 @@ slotFromWord64 = GYSlot -- | Advance 'GYSlot' forward. If slot value overflows, return 'Nothing'. advanceSlot :: GYSlot -> Natural -> Maybe GYSlot advanceSlot (GYSlot s) t - | st > fromIntegral (maxBound :: Word64) = Nothing - | otherwise = Just (GYSlot (fromIntegral st)) + | st > fromIntegral (maxBound :: Word64) = Nothing + | otherwise = Just (GYSlot (fromIntegral st)) where st :: Natural st = fromIntegral s + t @@ -74,6 +74,6 @@ unsafeAdvanceSlot (GYSlot s) t = GYSlot (s + fromIntegral t) -- | Convert from regular integer, which might under or overflow. unsafeSlotFromInteger :: Integer -> GYSlot unsafeSlotFromInteger s - | s > toInteger (maxBound :: Word64) = error "slot overflow" - | s < toInteger (minBound :: Word64) = error "slot underflow" - | otherwise = GYSlot (fromInteger s) + | s > toInteger (maxBound :: Word64) = error "slot overflow" + | s < toInteger (minBound :: Word64) = error "slot underflow" + | otherwise = GYSlot (fromInteger s) diff --git a/src/GeniusYield/Types/SlotConfig.hs b/src/GeniusYield/Types/SlotConfig.hs index 02f57930..a5f78695 100644 --- a/src/GeniusYield/Types/SlotConfig.hs +++ b/src/GeniusYield/Types/SlotConfig.hs @@ -1,54 +1,57 @@ {-# LANGUAGE PatternSynonyms #-} -{-| + +{- | Module : GeniusYield.Types.SlotConfig Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.SlotConfig ( - GYSlotConfig (gyscSystemStart, gyscEraSlotConfigs), - GYEraSlotConfig, - makeSlotConfig, - simpleSlotConfig, - slotToBeginTimePure, - slotToEndTimePure, - enclosingSlotFromTimePure, - unsafeEnclosingSlotFromTimePure, + GYSlotConfig (gyscSystemStart, gyscEraSlotConfigs), + GYEraSlotConfig, + makeSlotConfig, + simpleSlotConfig, + slotToBeginTimePure, + slotToEndTimePure, + enclosingSlotFromTimePure, + unsafeEnclosingSlotFromTimePure, ) where -import Control.Monad (unless, (<$!>)) -import Control.Monad.Except (Except, - MonadError (throwError), - runExcept) -import Data.Fixed (div') -import Data.Foldable (toList) -import Data.Functor (($>)) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Maybe (fromMaybe) -import Data.Time (NominalDiffTime) -import qualified Data.Time as Time -import qualified Data.Time.Clock.POSIX as Time -import Data.Word (Word64) - -import qualified Cardano.Api as Api -import qualified Cardano.Slotting.Slot as CSlot -import qualified Cardano.Slotting.Time as CSlot -import qualified Data.SOP.NonEmpty as Ouroboros -import qualified Ouroboros.Consensus.BlockchainTime as Ouroboros -import qualified Ouroboros.Consensus.HardFork.History as Ouroboros - -import GeniusYield.CardanoApi.EraHistory -import GeniusYield.Types.Slot -import GeniusYield.Types.Time +import Control.Monad (unless, (<$!>)) +import Control.Monad.Except ( + Except, + MonadError (throwError), + runExcept, + ) +import Data.Fixed (div') +import Data.Foldable (toList) +import Data.Functor (($>)) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (fromMaybe) +import Data.Time (NominalDiffTime) +import Data.Time qualified as Time +import Data.Time.Clock.POSIX qualified as Time +import Data.Word (Word64) + +import Cardano.Api qualified as Api +import Cardano.Slotting.Slot qualified as CSlot +import Cardano.Slotting.Time qualified as CSlot +import Data.SOP.NonEmpty qualified as Ouroboros +import Ouroboros.Consensus.BlockchainTime qualified as Ouroboros +import Ouroboros.Consensus.HardFork.History qualified as Ouroboros + +import GeniusYield.CardanoApi.EraHistory +import GeniusYield.Types.Slot +import GeniusYield.Types.Time -- --- $setup --- --- >>> import qualified Data.Time.Clock.POSIX as Time --- >>> import GeniusYield.Types --- + +{- $setup + +>>> import qualified Data.Time.Clock.POSIX as Time +>>> import GeniusYield.Types +-} {- Note [Slot Config Design] @@ -76,13 +79,13 @@ a smart contract. -- | Information about slot config for a particular ledger era. data GYEraSlotConfig = GYEraSlotConfig - { gyEraSlotStart :: !GYSlot - -- ^ The slot with which the era started (inclusive). - , gyEraSlotLength :: !CSlot.SlotLength - -- ^ The slot length as set in the era. - , gyEraSlotZeroTime :: !CSlot.RelativeTime - -- ^ The time when the era started, relative to 'CSlot.SystemStart' in 'GYSlotConfig'. - } + { gyEraSlotStart :: !GYSlot + -- ^ The slot with which the era started (inclusive). + , gyEraSlotLength :: !CSlot.SlotLength + -- ^ The slot length as set in the era. + , gyEraSlotZeroTime :: !CSlot.RelativeTime + -- ^ The time when the era started, relative to 'CSlot.SystemStart' in 'GYSlotConfig'. + } deriving stock (Eq, Show) {- | Slot config for each era, alongside the absolute system start time. @@ -96,9 +99,9 @@ data GYEraSlotConfig = GYEraSlotConfig - The final era element must be the current era, and it is _assumed_ that its end is unbounded (realistic). -} data GYSlotConfig = GYSlotConfig - { gyscSystemStart :: !CSlot.SystemStart - , gyscEraSlotConfigs :: !(NonEmpty GYEraSlotConfig) - } + { gyscSystemStart :: !CSlot.SystemStart + , gyscEraSlotConfigs :: !(NonEmpty GYEraSlotConfig) + } deriving stock (Eq, Show) {- | Create a 'GYSlotConfig' from the system start and the cardano era history. @@ -110,21 +113,24 @@ makeSlotConfig sysStart eraHist = GYSlotConfig sysStart <$!> simplifiedEraSumms where simplifiedEraSumms :: Either String (NonEmpty GYEraSlotConfig) !simplifiedEraSumms = case extractEraSummaries eraHist of - -- This pattern match ensures the summaries start with the very first era (Bound should be all 0). - summ@(Ouroboros.Summary eraSumms@(Ouroboros.NonEmptyCons Ouroboros.EraSummary {eraStart = FirstEraBound} _)) - -- Verify the rest of the invariants. - -> runExcept (invariantSummary summ) - -- Convert the summaries into a collection of 'GYEraSlotConfig'. - $> (toEraSlotConf <$!> toNonEmpty eraSumms) - _ -> Left $! "Initial era element within given EraHistory must be the very first ledger era" + -- This pattern match ensures the summaries start with the very first era (Bound should be all 0). + summ@(Ouroboros.Summary eraSumms@(Ouroboros.NonEmptyCons Ouroboros.EraSummary {eraStart = FirstEraBound} _)) -> + -- Verify the rest of the invariants. + runExcept (invariantSummary summ) + -- Convert the summaries into a collection of 'GYEraSlotConfig'. + $> (toEraSlotConf <$!> toNonEmpty eraSumms) + _ -> + Left $! + "Initial era element within given EraHistory must be the very first ledger era" ++ " (Era Start bound should be 0)" toEraSlotConf :: Ouroboros.EraSummary -> GYEraSlotConfig - toEraSlotConf Ouroboros.EraSummary + toEraSlotConf + Ouroboros.EraSummary { eraStart = Ouroboros.Bound {boundTime, boundSlot} , eraParams = Ouroboros.EraParams {eraSlotLength} - } = GYEraSlotConfig { gyEraSlotStart = slotFromApi boundSlot, gyEraSlotLength = eraSlotLength, gyEraSlotZeroTime = boundTime } + } = GYEraSlotConfig {gyEraSlotStart = slotFromApi boundSlot, gyEraSlotLength = eraSlotLength, gyEraSlotZeroTime = boundTime} toNonEmpty :: Ouroboros.NonEmpty xs a -> NonEmpty a - toNonEmpty (Ouroboros.NonEmptyOne x) = x :| [] + toNonEmpty (Ouroboros.NonEmptyOne x) = x :| [] toNonEmpty (Ouroboros.NonEmptyCons x xs) = x :| toList xs -- The era start bound for the very first era. @@ -136,92 +142,96 @@ pattern FirstEraBound <- Ouroboros.Bound (CSlot.RelativeTime 0) 0 (CSlot.EpochNo DO NOT USE for testnets/mainnet. Please use 'makeSlotConfig' instead. -} simpleSlotConfig :: Time.UTCTime -> Time.NominalDiffTime -> GYSlotConfig -simpleSlotConfig zero len = GYSlotConfig (CSlot.SystemStart zero) - $ GYEraSlotConfig - { gyEraSlotStart = slotFromApi 0 - , gyEraSlotZeroTime = CSlot.RelativeTime 0 - , gyEraSlotLength = CSlot.mkSlotLength len - } - :| [] - --- | Get the starting 'GYTime' of a 'GYSlot' given a 'GYSlotConfig'. --- --- >>> slotToBeginTimePure (simpleSlotConfig (Time.posixSecondsToUTCTime 10) 2) (unsafeSlotFromInteger 1) --- GYTime 12s --- +simpleSlotConfig zero len = + GYSlotConfig (CSlot.SystemStart zero) $ + GYEraSlotConfig + { gyEraSlotStart = slotFromApi 0 + , gyEraSlotZeroTime = CSlot.RelativeTime 0 + , gyEraSlotLength = CSlot.mkSlotLength len + } + :| [] + +{- | Get the starting 'GYTime' of a 'GYSlot' given a 'GYSlotConfig'. + +>>> slotToBeginTimePure (simpleSlotConfig (Time.posixSecondsToUTCTime 10) 2) (unsafeSlotFromInteger 1) +GYTime 12s +-} slotToBeginTimePure :: GYSlotConfig -> GYSlot -> GYTime slotToBeginTimePure sc slot = timeFromPOSIX $ slotToBeginPOSIXTime' sc slot slotToBeginPOSIXTime' :: GYSlotConfig -> GYSlot -> Time.POSIXTime -slotToBeginPOSIXTime' (GYSlotConfig sysStart slotConfs) slot = Time.utcTimeToPOSIXSeconds - -- SystemStart + relativeResult - $ CSlot.fromRelativeTime sysStart relativeResult +slotToBeginPOSIXTime' (GYSlotConfig sysStart slotConfs) slot = + Time.utcTimeToPOSIXSeconds + -- SystemStart + relativeResult + $ + CSlot.fromRelativeTime sysStart relativeResult where -- slotZeroTime + (slot - startSlotNo) * slotLength - relativeResult = CSlot.getSlotLength gyEraSlotLength + relativeResult = + CSlot.getSlotLength gyEraSlotLength `CSlot.multNominalDiffTime` (slotToInteger slot - slotToInteger gyEraSlotStart) `CSlot.addRelativeTime` gyEraSlotZeroTime - GYEraSlotConfig { gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength } = findSlotConf slotConfs + GYEraSlotConfig {gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength} = findSlotConf slotConfs {- Finds the slot config for the given slot. Essentially, the chosen slot config must have its starting slot less than, or equal to, the given slot. Furthermore, the chosen slot config's end slot, i.e next slot config's starting slot (or unbounded if final era), should be greater than the given slot. -} findSlotConf (x :| []) = x findSlotConf - (thisSlotConf@GYEraSlotConfig {gyEraSlotStart = startSlot} :| nextSlotConf@GYEraSlotConfig {gyEraSlotStart = endSlot} : rest) - = if slot >= startSlot && slot < endSlot then thisSlotConf else findSlotConf $ nextSlotConf :| rest + (thisSlotConf@GYEraSlotConfig {gyEraSlotStart = startSlot} :| nextSlotConf@GYEraSlotConfig {gyEraSlotStart = endSlot} : rest) = + if slot >= startSlot && slot < endSlot then thisSlotConf else findSlotConf $ nextSlotConf :| rest --- | Get the ending 'GYTime' of a 'GYSlot' (inclusive) given a 'GYSlotConfig'. --- --- >>> slotToEndTimePure (simpleSlotConfig (Time.posixSecondsToUTCTime 10) 2) (unsafeSlotFromInteger 1) --- GYTime 13.999s --- +{- | Get the ending 'GYTime' of a 'GYSlot' (inclusive) given a 'GYSlotConfig'. + +>>> slotToEndTimePure (simpleSlotConfig (Time.posixSecondsToUTCTime 10) 2) (unsafeSlotFromInteger 1) +GYTime 13.999s +-} slotToEndTimePure :: GYSlotConfig -> GYSlot -> GYTime slotToEndTimePure sc@(GYSlotConfig _ _) slot = - timeFromPOSIX $ slotToBeginPOSIXTime' sc (unsafeAdvanceSlot slot 1) - oneMs + timeFromPOSIX $ slotToBeginPOSIXTime' sc (unsafeAdvanceSlot slot 1) - oneMs where oneMs :: Time.NominalDiffTime oneMs = 0.001 --- | Get the 'GYSlot' of a 'GYTime' given a 'GYSlotConfig'. --- --- Returns 'Nothing' if given time is before known system start. --- --- >>> enclosingSlotFromTimePure (simpleSlotConfig (Time.posixSecondsToUTCTime 10) 2) (timeFromPOSIX 12) --- Just (GYSlot 1) --- --- >>> enclosingSlotFromTimePure (simpleSlotConfig (Time.posixSecondsToUTCTime 10) 2) (timeFromPOSIX 14) --- Just (GYSlot 2) --- +{- | Get the 'GYSlot' of a 'GYTime' given a 'GYSlotConfig'. + +Returns 'Nothing' if given time is before known system start. + +>>> enclosingSlotFromTimePure (simpleSlotConfig (Time.posixSecondsToUTCTime 10) 2) (timeFromPOSIX 12) +Just (GYSlot 1) + +>>> enclosingSlotFromTimePure (simpleSlotConfig (Time.posixSecondsToUTCTime 10) 2) (timeFromPOSIX 14) +Just (GYSlot 2) +-} enclosingSlotFromTimePure :: GYSlotConfig -> GYTime -> Maybe GYSlot enclosingSlotFromTimePure (GYSlotConfig sysStart slotConfs) (timeToPOSIX -> absTime) - | absTimeUtc < CSlot.getSystemStart sysStart = Nothing - | otherwise = - -- startSlotNo + relativeResult - Just . slotFromApi . Ouroboros.addSlots relativeResult $ slotToApi gyEraSlotStart + | absTimeUtc < CSlot.getSystemStart sysStart = Nothing + | otherwise = + -- startSlotNo + relativeResult + Just . slotFromApi . Ouroboros.addSlots relativeResult $ slotToApi gyEraSlotStart where absTimeUtc = Time.posixSecondsToUTCTime absTime -- absTime - SystemStart relTime = CSlot.toRelativeTime sysStart absTimeUtc -- (relTime - slotZeroTime) / slotLength relativeResult = (relTime `CSlot.diffRelativeTime` gyEraSlotZeroTime) `div'` CSlot.getSlotLength gyEraSlotLength - GYEraSlotConfig { gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength } = findSlotConf slotConfs + GYEraSlotConfig {gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength} = findSlotConf slotConfs {- Finds the slot config for the given relative time. Essentially, the chosen slot config must have its starting time greater than, or equal to, the given relative time. Furthermore, the chosen slot config's end time, i.e next slot config's starting time (or unbounded if final era), should be greater than the given relative time. -} findSlotConf (x :| []) = x findSlotConf - ( thisSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = startTime} - :| nextSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = endTime} - : rest - ) - = if relTime >= startTime && relTime < endTime then thisSlotConf else findSlotConf $ nextSlotConf :| rest + ( thisSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = startTime} + :| nextSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = endTime} + : rest + ) = + if relTime >= startTime && relTime < endTime then thisSlotConf else findSlotConf $ nextSlotConf :| rest -- | Partial version of 'enclosingSlotFromTimePure'. unsafeEnclosingSlotFromTimePure :: GYSlotConfig -> GYTime -> GYSlot unsafeEnclosingSlotFromTimePure sc = - fromMaybe (error "Given time is before system start") + fromMaybe (error "Given time is before system start") . enclosingSlotFromTimePure sc ---------------------------------- @@ -237,61 +247,68 @@ https://github.com/input-output-hk/ouroboros-network/issues/4100 -} invariantSummary :: Ouroboros.Summary xs -> Except String () invariantSummary = \(Ouroboros.Summary summary) -> - -- Pretend the start of the first era is the "end of the previous" one - go (Ouroboros.eraStart (Ouroboros.nonEmptyHead summary)) (toList summary) + -- Pretend the start of the first era is the "end of the previous" one + go (Ouroboros.eraStart (Ouroboros.nonEmptyHead summary)) (toList summary) where - go :: Ouroboros.Bound -- ^ End of the previous era - -> [Ouroboros.EraSummary] -> Except String () - go _ [] = return () + go :: + Ouroboros.Bound -> + -- \^ End of the previous era + [Ouroboros.EraSummary] -> + Except String () + go _ [] = return () go prevEnd (curSummary : next) = do - unless (curStart == prevEnd) $ - throwError $ mconcat [ - "Bounds don't line up: end of previous era " + unless (curStart == prevEnd) $ + throwError $ + mconcat + [ "Bounds don't line up: end of previous era " , show prevEnd , " /= start of current era " , show curStart ] - case mCurEnd of - Ouroboros.EraUnbounded -> - unless (null next) $ - throwError "Unbounded non-final era" - Ouroboros.EraEnd curEnd -> do - -- Check the invariants mentioned at 'EraSummary' - -- - -- o @epochsInEra@ corresponds to @e' - e@ - -- o @slotsInEra@ corresponds to @(e' - e) * epochSize)@ - -- o @timeInEra@ corresponds to @((e' - e) * epochSize * slotLen@ - -- which, if INV-1b holds, equals @(s' - s) * slotLen@ - let epochsInEra, slotsInEra :: Word64 - epochsInEra = Ouroboros.countEpochs (Ouroboros.boundEpoch curEnd) (Ouroboros.boundEpoch curStart) - slotsInEra = epochsInEra * CSlot.unEpochSize (Ouroboros.eraEpochSize curParams) - - timeInEra :: NominalDiffTime - timeInEra = fromIntegral slotsInEra - * CSlot.getSlotLength (Ouroboros.eraSlotLength curParams) - - -- NOTE: The only change is here, using >= rather than > - unless (Ouroboros.boundEpoch curEnd >= Ouroboros.boundEpoch curStart) $ - throwError "Empty era" - - unless (Ouroboros.boundSlot curEnd == Ouroboros.addSlots slotsInEra (Ouroboros.boundSlot curStart)) $ - throwError $ mconcat [ - "Invalid final boundSlot in " + case mCurEnd of + Ouroboros.EraUnbounded -> + unless (null next) $ + throwError "Unbounded non-final era" + Ouroboros.EraEnd curEnd -> do + -- Check the invariants mentioned at 'EraSummary' + -- + -- o @epochsInEra@ corresponds to @e' - e@ + -- o @slotsInEra@ corresponds to @(e' - e) * epochSize)@ + -- o @timeInEra@ corresponds to @((e' - e) * epochSize * slotLen@ + -- which, if INV-1b holds, equals @(s' - s) * slotLen@ + let epochsInEra, slotsInEra :: Word64 + epochsInEra = Ouroboros.countEpochs (Ouroboros.boundEpoch curEnd) (Ouroboros.boundEpoch curStart) + slotsInEra = epochsInEra * CSlot.unEpochSize (Ouroboros.eraEpochSize curParams) + + timeInEra :: NominalDiffTime + timeInEra = + fromIntegral slotsInEra + * CSlot.getSlotLength (Ouroboros.eraSlotLength curParams) + + -- NOTE: The only change is here, using >= rather than > + unless (Ouroboros.boundEpoch curEnd >= Ouroboros.boundEpoch curStart) $ + throwError "Empty era" + + unless (Ouroboros.boundSlot curEnd == Ouroboros.addSlots slotsInEra (Ouroboros.boundSlot curStart)) $ + throwError $ + mconcat + [ "Invalid final boundSlot in " , show curSummary , " (INV-1b)" ] - unless (Ouroboros.boundTime curEnd == Ouroboros.addRelTime timeInEra (Ouroboros.boundTime curStart)) $ - throwError $ mconcat [ - "Invalid final boundTime in " + unless (Ouroboros.boundTime curEnd == Ouroboros.addRelTime timeInEra (Ouroboros.boundTime curStart)) $ + throwError $ + mconcat + [ "Invalid final boundTime in " , show curSummary , " (INV-2b)" ] - go curEnd next + go curEnd next where - curStart :: Ouroboros.Bound - mCurEnd :: Ouroboros.EraEnd + curStart :: Ouroboros.Bound + mCurEnd :: Ouroboros.EraEnd curParams :: Ouroboros.EraParams Ouroboros.EraSummary curStart mCurEnd curParams = curSummary diff --git a/src/GeniusYield/Types/StakeAddressInfo.hs b/src/GeniusYield/Types/StakeAddressInfo.hs index 5bf35761..95ad3553 100644 --- a/src/GeniusYield/Types/StakeAddressInfo.hs +++ b/src/GeniusYield/Types/StakeAddressInfo.hs @@ -1,19 +1,19 @@ -{-| +{- | Module : GeniusYield.Types.StakeAddressInfo Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.StakeAddressInfo ( - GYStakeAddressInfo (..), + GYStakeAddressInfo (..), ) where -import GeniusYield.Imports -import GeniusYield.Types.StakePoolId (GYStakePoolId) +import GeniusYield.Imports +import GeniusYield.Types.StakePoolId (GYStakePoolId) data GYStakeAddressInfo = GYStakeAddressInfo - { gyStakeAddressInfoDelegatedPool :: Maybe GYStakePoolId + { gyStakeAddressInfoDelegatedPool :: Maybe GYStakePoolId , gyStakeAddressInfoAvailableRewards :: Natural - } deriving stock (Eq, Show) + } + deriving stock (Eq, Show) diff --git a/src/GeniusYield/Types/StakeKeyHash.hs b/src/GeniusYield/Types/StakeKeyHash.hs index fa6cf42d..0a4cafd2 100644 --- a/src/GeniusYield/Types/StakeKeyHash.hs +++ b/src/GeniusYield/Types/StakeKeyHash.hs @@ -1,47 +1,50 @@ -{-| +{- | Module : GeniusYield.Types.StakeKeyHash Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.StakeKeyHash ( - GYStakeKeyHash, - stakeKeyHashToApi, - stakeKeyHashFromApi, - stakeKeyHashToLedger, - stakeKeyHashFromLedger, + GYStakeKeyHash, + stakeKeyHashToApi, + stakeKeyHashFromApi, + stakeKeyHashToLedger, + stakeKeyHashFromLedger, ) where -import Control.Lens ((?~)) -import GeniusYield.Imports - -import qualified Cardano.Api as Api -import qualified Cardano.Api.Ledger as Ledger -import qualified Cardano.Api.Shelley as Api -import qualified Cardano.Ledger.Keys as Ledger -import qualified Data.Aeson.Types as Aeson -import qualified Data.Csv as Csv -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Text.Encoding as Text -import GeniusYield.Types.PubKeyHash (AsPubKeyHash (..), CanSignTx, - pubKeyHashFromLedger, - pubKeyHashToLedger) -import qualified Text.Printf as Printf - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import qualified Data.Csv as Csv --- >>> import qualified Text.Printf as Printf +import Control.Lens ((?~)) +import GeniusYield.Imports + +import Cardano.Api qualified as Api +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api +import Cardano.Ledger.Keys qualified as Ledger +import Data.Aeson.Types qualified as Aeson +import Data.Csv qualified as Csv +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Text.Encoding qualified as Text +import GeniusYield.Types.PubKeyHash ( + AsPubKeyHash (..), + CanSignTx, + pubKeyHashFromLedger, + pubKeyHashToLedger, + ) +import Text.Printf qualified as Printf + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import qualified Data.Csv as Csv +>>> import qualified Text.Printf as Printf +-} newtype GYStakeKeyHash = GYStakeKeyHash (Api.Hash Api.StakeKey) - deriving stock Show - deriving newtype (Eq, Ord, IsString) + deriving stock (Show) + deriving newtype (Eq, Ord, IsString) instance AsPubKeyHash GYStakeKeyHash where toPubKeyHash = stakeKeyHashToLedger >>> Ledger.coerceKeyRole >>> pubKeyHashFromLedger @@ -49,20 +52,20 @@ instance AsPubKeyHash GYStakeKeyHash where instance CanSignTx GYStakeKeyHash --- | --- --- >>> let Just skh = Aeson.decode @GYStakeKeyHash "\"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d\"" --- >>> stakeKeyHashToApi skh --- "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- +{- | + +>>> let Just skh = Aeson.decode @GYStakeKeyHash "\"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d\"" +>>> stakeKeyHashToApi skh +"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +-} stakeKeyHashToApi :: GYStakeKeyHash -> Api.Hash Api.StakeKey stakeKeyHashToApi = coerce --- | --- --- >>> stakeKeyHashFromApi "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- GYStakeKeyHash "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- +{- | + +>>> stakeKeyHashFromApi "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +GYStakeKeyHash "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +-} stakeKeyHashFromApi :: Api.Hash Api.StakeKey -> GYStakeKeyHash stakeKeyHashFromApi = coerce @@ -74,65 +77,75 @@ stakeKeyHashToLedger = stakeKeyHashToApi >>> Api.unStakeKeyHash stakeKeyHashFromLedger :: Ledger.KeyHash Ledger.Staking Ledger.StandardCrypto -> GYStakeKeyHash stakeKeyHashFromLedger = Api.StakeKeyHash >>> stakeKeyHashFromApi --- | --- --- >>> let Just skh = Aeson.decode @GYStakeKeyHash "\"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d\"" --- >>> LBS8.putStrLn $ Aeson.encode skh --- "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- +{- | + +>>> let Just skh = Aeson.decode @GYStakeKeyHash "\"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d\"" +>>> LBS8.putStrLn $ Aeson.encode skh +"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +-} instance Aeson.ToJSON GYStakeKeyHash where - toJSON = Aeson.toJSON . Api.serialiseToRawBytesHexText . stakeKeyHashToApi - --- | --- --- >>> Aeson.eitherDecode @GYStakeKeyHash "\"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d\"" --- Right (GYStakeKeyHash "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d") --- --- Invalid characters: --- --- >>> Aeson.eitherDecode @GYStakeKeyHash "\"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab2340386323zzz\"" --- Left "Error in $: RawBytesHexErrorBase16DecodeFail \"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab2340386323zzz\" \"invalid character at offset: 53\"" --- + toJSON = Aeson.toJSON . Api.serialiseToRawBytesHexText . stakeKeyHashToApi + +{- | + +>>> Aeson.eitherDecode @GYStakeKeyHash "\"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d\"" +Right (GYStakeKeyHash "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d") + +Invalid characters: + +>>> Aeson.eitherDecode @GYStakeKeyHash "\"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab2340386323zzz\"" +Left "Error in $: RawBytesHexErrorBase16DecodeFail \"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab2340386323zzz\" \"invalid character at offset: 53\"" +-} instance Aeson.FromJSON GYStakeKeyHash where - parseJSON = Aeson.withText "GYStakeKeyHash" $ - either - (fail . show) - (return . GYStakeKeyHash) + parseJSON = + Aeson.withText "GYStakeKeyHash" $ + either + (fail . show) + (return . GYStakeKeyHash) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsStakeKey) . Text.encodeUtf8 --- | --- --- >>> Printf.printf "%s\n" $ stakeKeyHashFromApi "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- 7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d --- +{- | + +>>> Printf.printf "%s\n" $ stakeKeyHashFromApi "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d +-} instance Printf.PrintfArg GYStakeKeyHash where - formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . stakeKeyHashToApi + formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . stakeKeyHashToApi + +{- | --- | --- --- >>> Csv.toField @GYStakeKeyHash "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- +>>> Csv.toField @GYStakeKeyHash "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +"7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +-} instance Csv.ToField GYStakeKeyHash where - toField = Api.serialiseToRawBytesHex . stakeKeyHashToApi - --- | --- --- >>> Csv.runParser $ Csv.parseField @GYStakeKeyHash "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" --- Right (GYStakeKeyHash "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d") --- --- >>> Csv.runParser $ Csv.parseField @GYStakeKeyHash "not a pub stake key hash" --- Left "RawBytesHexErrorBase16DecodeFail \"not a pub stake key hash\" \"invalid character at offset: 0\"" --- + toField = Api.serialiseToRawBytesHex . stakeKeyHashToApi + +{- | + +>>> Csv.runParser $ Csv.parseField @GYStakeKeyHash "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" +Right (GYStakeKeyHash "7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d") + +>>> Csv.runParser $ Csv.parseField @GYStakeKeyHash "not a pub stake key hash" +Left "RawBytesHexErrorBase16DecodeFail \"not a pub stake key hash\" \"invalid character at offset: 0\"" +-} instance Csv.FromField GYStakeKeyHash where - parseField = either (fail . show) (return . stakeKeyHashFromApi) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsStakeKey) + parseField = either (fail . show) (return . stakeKeyHashFromApi) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsStakeKey) instance Swagger.ToSchema GYStakeKeyHash where - declareNamedSchema _ = pure $ Swagger.named "GYStakeKeyHash" $ mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "hex" - & Swagger.description ?~ "The hash of a public stake key." - & Swagger.example ?~ toJSON ("7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" :: Text) - & Swagger.maxLength ?~ 56 - & Swagger.minLength ?~ 56 + declareNamedSchema _ = + pure $ + Swagger.named "GYStakeKeyHash" $ + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "hex" + & Swagger.description + ?~ "The hash of a public stake key." + & Swagger.example + ?~ toJSON ("7a77d120b9e86addc7388dbbb1bd2350490b7d140ab234038632334d" :: Text) + & Swagger.maxLength + ?~ 56 + & Swagger.minLength + ?~ 56 diff --git a/src/GeniusYield/Types/StakePoolId.hs b/src/GeniusYield/Types/StakePoolId.hs index 9dfd1d78..2d3bba35 100644 --- a/src/GeniusYield/Types/StakePoolId.hs +++ b/src/GeniusYield/Types/StakePoolId.hs @@ -1,10 +1,9 @@ -{-| +{- | Module : GeniusYield.Types.StakePoolId Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.StakePoolId ( GYStakePoolId, @@ -17,63 +16,66 @@ module GeniusYield.Types.StakePoolId ( stakePoolIdToText, GYStakePoolIdBech32, stakePoolIdFromBech32, - stakePoolIdToBech32 + stakePoolIdToBech32, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Ledger as Ledger -import qualified Cardano.Api.Shelley as Api -import qualified Cardano.Ledger.Keys as Ledger -import Control.Lens ((?~)) -import qualified Data.Aeson.Types as Aeson -import qualified Data.Csv as Csv -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import GeniusYield.Imports -import GeniusYield.Types.PubKeyHash (AsPubKeyHash (..), - pubKeyHashFromLedger, - pubKeyHashToLedger) -import qualified Text.Printf as Printf -import qualified Web.HttpApiData as Web - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import qualified Data.Csv as Csv --- >>> import qualified Text.Printf as Printf --- >>> import Data.Proxy --- >>> import qualified Data.Swagger as Swagger --- >>> import qualified Web.HttpApiData as Web --- --- >>> spId :: GYStakePoolId = "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" +import Cardano.Api qualified as Api +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api +import Cardano.Ledger.Keys qualified as Ledger +import Control.Lens ((?~)) +import Data.Aeson.Types qualified as Aeson +import Data.Csv qualified as Csv +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import GeniusYield.Imports +import GeniusYield.Types.PubKeyHash ( + AsPubKeyHash (..), + pubKeyHashFromLedger, + pubKeyHashToLedger, + ) +import Text.Printf qualified as Printf +import Web.HttpApiData qualified as Web + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import qualified Data.Csv as Csv +>>> import qualified Text.Printf as Printf +>>> import Data.Proxy +>>> import qualified Data.Swagger as Swagger +>>> import qualified Web.HttpApiData as Web +>>> spId :: GYStakePoolId = "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" +-} newtype GYStakePoolId = GYStakePoolId (Api.Hash Api.StakePoolKey) - deriving newtype (Eq, Ord, IsString) + deriving newtype (Eq, Ord, IsString) instance Show GYStakePoolId where - showsPrec d spId = showParen (d > 10) $ - showString "unsafeStakePoolIdFromText " . - showsPrec 11 (stakePoolIdToText spId) - --- | --- --- >>> let Just spid = Aeson.decode @GYStakePoolId "\"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27\"" --- >>> stakePoolIdToApi spid --- "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" --- + showsPrec d spId = + showParen (d > 10) $ + showString "unsafeStakePoolIdFromText " + . showsPrec 11 (stakePoolIdToText spId) + +{- | + +>>> let Just spid = Aeson.decode @GYStakePoolId "\"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27\"" +>>> stakePoolIdToApi spid +"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" +-} stakePoolIdToApi :: GYStakePoolId -> Api.Hash Api.StakePoolKey stakePoolIdToApi = coerce --- | --- --- >>> stakePoolIdFromApi "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" --- unsafeStakePoolIdFromText "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" --- +{- | + +>>> stakePoolIdFromApi "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" +unsafeStakePoolIdFromText "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" +-} stakePoolIdFromApi :: Api.Hash Api.StakePoolKey -> GYStakePoolId stakePoolIdFromApi = coerce @@ -91,105 +93,116 @@ instance AsPubKeyHash GYStakePoolId where toPubKeyHash = stakePoolIdToLedger >>> Ledger.coerceKeyRole >>> pubKeyHashFromLedger fromPubKeyHash = pubKeyHashToLedger >>> Ledger.coerceKeyRole >>> stakePoolIdFromLedger --- | --- --- >>> let Just spid = Aeson.decode @GYStakePoolId "\"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27\"" --- >>> LBS8.putStrLn $ Aeson.encode spid --- "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" --- +{- | + +>>> let Just spid = Aeson.decode @GYStakePoolId "\"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27\"" +>>> LBS8.putStrLn $ Aeson.encode spid +"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" +-} instance Aeson.ToJSON GYStakePoolId where - toJSON = Aeson.toJSON . Api.serialiseToRawBytesHexText . stakePoolIdToApi - --- | --- --- >>> Aeson.eitherDecode @GYStakePoolId "\"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27\"" --- Right (unsafeStakePoolIdFromText "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt") --- --- Invalid characters: --- --- >>> Aeson.eitherDecode @GYStakePoolId "\"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fzzz\"" --- Left "Error in $: RawBytesHexErrorBase16DecodeFail \"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fzzz\" \"invalid character at offset: 53\"" --- + toJSON = Aeson.toJSON . Api.serialiseToRawBytesHexText . stakePoolIdToApi + +{- | + +>>> Aeson.eitherDecode @GYStakePoolId "\"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27\"" +Right (unsafeStakePoolIdFromText "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt") + +Invalid characters: + +>>> Aeson.eitherDecode @GYStakePoolId "\"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fzzz\"" +Left "Error in $: RawBytesHexErrorBase16DecodeFail \"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fzzz\" \"invalid character at offset: 53\"" +-} instance Aeson.FromJSON GYStakePoolId where - parseJSON = Aeson.withText "GYStakePoolId" $ - either - (fail . show) - (return . GYStakePoolId) + parseJSON = + Aeson.withText "GYStakePoolId" $ + either + (fail . show) + (return . GYStakePoolId) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsStakePoolKey) . Text.encodeUtf8 --- | --- --- >>> Printf.printf "%s\n" $ stakePoolIdFromApi "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" --- c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27 --- +{- | + +>>> Printf.printf "%s\n" $ stakePoolIdFromApi "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" +c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27 +-} instance Printf.PrintfArg GYStakePoolId where - formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . stakePoolIdToApi + formatArg = Printf.formatArg . Api.serialiseToRawBytesHexText . stakePoolIdToApi --- | --- --- >>> Csv.toField @GYStakePoolId "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" --- "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" --- +{- | + +>>> Csv.toField @GYStakePoolId "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" +"c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" +-} instance Csv.ToField GYStakePoolId where - toField = Api.serialiseToRawBytesHex . stakePoolIdToApi - --- | --- --- >>> Csv.runParser $ Csv.parseField @GYStakePoolId "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" --- Right (unsafeStakePoolIdFromText "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt") --- --- >>> Csv.runParser $ Csv.parseField @GYStakePoolId "not a pub stake key hash" --- Left "RawBytesHexErrorBase16DecodeFail \"not a pub stake key hash\" \"invalid character at offset: 0\"" --- + toField = Api.serialiseToRawBytesHex . stakePoolIdToApi + +{- | + +>>> Csv.runParser $ Csv.parseField @GYStakePoolId "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" +Right (unsafeStakePoolIdFromText "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt") + +>>> Csv.runParser $ Csv.parseField @GYStakePoolId "not a pub stake key hash" +Left "RawBytesHexErrorBase16DecodeFail \"not a pub stake key hash\" \"invalid character at offset: 0\"" +-} instance Csv.FromField GYStakePoolId where - parseField = either (fail . show) (return . stakePoolIdFromApi) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsStakePoolKey) + parseField = either (fail . show) (return . stakePoolIdFromApi) . Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsStakePoolKey) instance Swagger.ToSchema GYStakePoolId where - declareNamedSchema _ = pure $ Swagger.named "GYStakePoolId" $ mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "hex" - & Swagger.description ?~ "The hash of a public stake pool key." - & Swagger.example ?~ toJSON ("c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" :: Text) - & Swagger.maxLength ?~ 56 - & Swagger.minLength ?~ 56 - --- | Obtain `GYStakePoolId` from bech32 encoding of stake pool id. --- --- >>> stakePoolIdFromTextMaybe "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" --- Just (unsafeStakePoolIdFromText "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt") --- >>> stakePoolIdFromTextMaybe "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" --- Nothing --- + declareNamedSchema _ = + pure $ + Swagger.named "GYStakePoolId" $ + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "hex" + & Swagger.description + ?~ "The hash of a public stake pool key." + & Swagger.example + ?~ toJSON ("c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" :: Text) + & Swagger.maxLength + ?~ 56 + & Swagger.minLength + ?~ 56 + +{- | Obtain `GYStakePoolId` from bech32 encoding of stake pool id. + +>>> stakePoolIdFromTextMaybe "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" +Just (unsafeStakePoolIdFromText "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt") +>>> stakePoolIdFromTextMaybe "c485ab20bd3f105e59f3c50a0d3fbaf615a51f70a1c6d29d00a1fd27" +Nothing +-} stakePoolIdFromTextMaybe :: Text.Text -> Maybe GYStakePoolId stakePoolIdFromTextMaybe t = case Api.deserialiseFromBech32 (Api.AsHash Api.AsStakePoolKey) t of - Left _ -> Nothing - Right h -> Just $ stakePoolIdFromApi h + Left _ -> Nothing + Right h -> Just $ stakePoolIdFromApi h -- | Like `stakePoolIdFromTextMaybe` but errors on `Nothing` case. unsafeStakePoolIdFromText :: Text.Text -> GYStakePoolId -unsafeStakePoolIdFromText t = fromMaybe +unsafeStakePoolIdFromText t = + fromMaybe (error $ "Not a stake pool id: " ++ show t) (stakePoolIdFromTextMaybe t) --- | Serialises `GYStakePoolId` to it's bech32 representation. --- --- >>> stakePoolIdToText spId --- "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" --- +{- | Serialises `GYStakePoolId` to it's bech32 representation. + +>>> stakePoolIdToText spId +"pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" +-} stakePoolIdToText :: GYStakePoolId -> Text.Text stakePoolIdToText = Api.serialiseToBech32 . stakePoolIdToApi --- | 'GYStakePoolIdBech32' which uses "bech32" format --- --- >>> Web.toUrlPiece $ stakePoolIdToBech32 spId --- "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" --- +{- | 'GYStakePoolIdBech32' which uses "bech32" format + +>>> Web.toUrlPiece $ stakePoolIdToBech32 spId +"pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" +-} newtype GYStakePoolIdBech32 = GYStakePoolIdBech32 GYStakePoolId deriving newtype (Eq, Ord) instance Show GYStakePoolIdBech32 where - show = Web.toUrlPiece >>> Text.unpack + show = Web.toUrlPiece >>> Text.unpack stakePoolIdToBech32 :: GYStakePoolId -> GYStakePoolIdBech32 stakePoolIdToBech32 = coerce @@ -198,51 +211,59 @@ stakePoolIdFromBech32 :: GYStakePoolIdBech32 -> GYStakePoolId stakePoolIdFromBech32 = coerce instance Web.ToHttpApiData GYStakePoolIdBech32 where - toUrlPiece = coerce stakePoolIdToText + toUrlPiece = coerce stakePoolIdToText instance IsString GYStakePoolIdBech32 where - fromString = fromRight (error "invalid stake pool id") . Web.parseUrlPiece . Text.pack + fromString = fromRight (error "invalid stake pool id") . Web.parseUrlPiece . Text.pack --- | --- --- >>> Web.parseUrlPiece @GYStakePoolIdBech32 "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" --- Right pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt --- +{- | + +>>> Web.parseUrlPiece @GYStakePoolIdBech32 "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" +Right pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt +-} instance Web.FromHttpApiData GYStakePoolIdBech32 where - parseUrlPiece t = case stakePoolIdFromTextMaybe t of - Just stakePoolId -> Right $ coerce stakePoolId - Nothing -> Left $ "Not a stake pool id: " <> t - --- | --- --- >>> LBS8.putStrLn $ Aeson.encode $ stakePoolIdToBech32 spId --- "pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" --- + parseUrlPiece t = case stakePoolIdFromTextMaybe t of + Just stakePoolId -> Right $ coerce stakePoolId + Nothing -> Left $ "Not a stake pool id: " <> t + +{- | + +>>> LBS8.putStrLn $ Aeson.encode $ stakePoolIdToBech32 spId +"pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" +-} instance ToJSON GYStakePoolIdBech32 where - toJSON (GYStakePoolIdBech32 stakePoolId) = Aeson.toJSON $ stakePoolIdToText stakePoolId + toJSON (GYStakePoolIdBech32 stakePoolId) = Aeson.toJSON $ stakePoolIdToText stakePoolId --- | --- --- >>> Aeson.decode @GYStakePoolIdBech32 "\"pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt\"" --- Just pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt --- +{- | + +>>> Aeson.decode @GYStakePoolIdBech32 "\"pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt\"" +Just pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt +-} instance FromJSON GYStakePoolIdBech32 where - parseJSON = Aeson.withText "GYStakePoolIdBech32" $ \t -> - case stakePoolIdFromTextMaybe t of - Just stakePoolId -> return $ GYStakePoolIdBech32 stakePoolId - Nothing -> fail "cannot deserialise stake pool id" - --- | --- --- >>> Aeson.encode (Swagger.toSchema (Proxy :: Proxy GYStakePoolIdBech32)) --- "{\"description\":\"A stake pool id, serialised as Bech32.\",\"example\":\"pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt\",\"format\":\"bech32\",\"type\":\"string\"}" --- + parseJSON = Aeson.withText "GYStakePoolIdBech32" $ \t -> + case stakePoolIdFromTextMaybe t of + Just stakePoolId -> return $ GYStakePoolIdBech32 stakePoolId + Nothing -> fail "cannot deserialise stake pool id" + +{- | + +>>> Aeson.encode (Swagger.toSchema (Proxy :: Proxy GYStakePoolIdBech32)) +"{\"description\":\"A stake pool id, serialised as Bech32.\",\"example\":\"pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt\",\"format\":\"bech32\",\"type\":\"string\"}" +-} instance Swagger.ToSchema GYStakePoolIdBech32 where - declareNamedSchema _ = pure $ Swagger.named "GYStakePoolIdBech32" $ Swagger.paramSchemaToSchema (Proxy @GYStakePoolIdBech32) - & Swagger.description ?~ "A stake pool id, serialised as Bech32." - & Swagger.example ?~ toJSON ("pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" :: GYStakePoolIdBech32) + declareNamedSchema _ = + pure $ + Swagger.named "GYStakePoolIdBech32" $ + Swagger.paramSchemaToSchema (Proxy @GYStakePoolIdBech32) + & Swagger.description + ?~ "A stake pool id, serialised as Bech32." + & Swagger.example + ?~ toJSON ("pool1cjz6kg9a8ug9uk0nc59q60a67c2628ms58rd98gq587jwa2x5qt" :: GYStakePoolIdBech32) instance Swagger.ToParamSchema GYStakePoolIdBech32 where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "bech32" + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "bech32" diff --git a/src/GeniusYield/Types/Time.hs b/src/GeniusYield/Types/Time.hs index 1d73f375..1169c776 100644 --- a/src/GeniusYield/Types/Time.hs +++ b/src/GeniusYield/Types/Time.hs @@ -1,101 +1,112 @@ -{-| +{- | Module : GeniusYield.Types.Time Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Types.Time - ( FormatTime (..), ParseTime (..) - , gyIso8601Show, gyIso8601ParseM - , GYTime - , getCurrentGYTime - , addSeconds - , timeFromPlutus - , timeToPlutus - , timeToPOSIX - , timeFromPOSIX - ) where - -import GeniusYield.Imports - -import Control.Lens ((?~)) -import qualified Data.Aeson as Aeson -import qualified Data.Csv as Csv -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Text as Text -import qualified Data.Time.Clock as Time -import qualified Data.Time.Clock.POSIX as Time -import Data.Time.Format.Internal (FormatTime (..), ParseTime (..)) -import qualified Data.Time.Format.ISO8601 as Time -import qualified PlutusLedgerApi.V1.Time as Plutus -import qualified Web.HttpApiData as Web +module GeniusYield.Types.Time ( + FormatTime (..), + ParseTime (..), + gyIso8601Show, + gyIso8601ParseM, + GYTime, + getCurrentGYTime, + addSeconds, + timeFromPlutus, + timeToPlutus, + timeToPOSIX, + timeFromPOSIX, +) where + +import GeniusYield.Imports + +import Control.Lens ((?~)) +import Data.Aeson qualified as Aeson +import Data.Csv qualified as Csv +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Text qualified as Text +import Data.Time.Clock qualified as Time +import Data.Time.Clock.POSIX qualified as Time +import Data.Time.Format.ISO8601 qualified as Time +import Data.Time.Format.Internal (FormatTime (..), ParseTime (..)) +import PlutusLedgerApi.V1.Time qualified as Plutus +import Web.HttpApiData qualified as Web ------------------------------------------------------------------------------- -- GYTime ------------------------------------------------------------------------------- --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import qualified Data.Csv as Csv --- >>> import Text.Printf (printf) --- >>> import qualified Web.HttpApiData as Web +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import qualified Data.Csv as Csv +>>> import Text.Printf (printf) +>>> import qualified Web.HttpApiData as Web +-} newtype GYTime = GYTime Time.POSIXTime - deriving (Show, Read) + deriving (Show, Read) deriving newtype (Eq, Ord, FormatTime) --- | --- --- >>> "1970-01-01T00:00:00Z" :: GYTime --- GYTime 0s --- --- >>> "1970-01-01T00:00:00" :: GYTime --- *** Exception: can't parse '1970-01-01T00:00:00' as GYTime in ISO8601 format --- ... --- +{- | + +>>> "1970-01-01T00:00:00Z" :: GYTime +GYTime 0s + +>>> "1970-01-01T00:00:00" :: GYTime +*** Exception: can't parse '1970-01-01T00:00:00' as GYTime in ISO8601 format +... +-} instance IsString GYTime where - fromString s = fromMaybe (error $ printf "can't parse '%s' as GYTime in ISO8601 format" s) $ gyIso8601ParseM s + fromString s = fromMaybe (error $ printf "can't parse '%s' as GYTime in ISO8601 format" s) $ gyIso8601ParseM s instance ParseTime GYTime where - parseTimeSpecifier _ = parseTimeSpecifier $ Proxy @Time.POSIXTime - buildTime loc xs = GYTime <$> buildTime loc xs + parseTimeSpecifier _ = parseTimeSpecifier $ Proxy @Time.POSIXTime + buildTime loc xs = GYTime <$> buildTime loc xs instance Swagger.ToParamSchema GYTime where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "string" + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "string" instance Swagger.ToSchema GYTime where - declareNamedSchema p = Swagger.plain $ Swagger.paramSchemaToSchema p - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.description ?~ "This is the posix time in ISO8601 format." - & Swagger.format ?~ "ISO8601" - & Swagger.example ?~ toJSON ("1970-01-01T00:00:00Z" :: Text) - --- | --- --- >>> Csv.toField @GYTime "1970-01-01T00:00:00Z" --- "1970-01-01T00:00:00Z" --- + declareNamedSchema p = + Swagger.plain $ + Swagger.paramSchemaToSchema p + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.description + ?~ "This is the posix time in ISO8601 format." + & Swagger.format + ?~ "ISO8601" + & Swagger.example + ?~ toJSON ("1970-01-01T00:00:00Z" :: Text) + +{- | + +>>> Csv.toField @GYTime "1970-01-01T00:00:00Z" +"1970-01-01T00:00:00Z" +-} instance Csv.ToField GYTime where - toField = encodeUtf8 . Text.pack . gyIso8601Show - --- | --- --- >>> Csv.runParser $ Csv.parseField @GYTime "1970-01-01T00:00:00Z" --- Right (GYTime 0s) --- --- >>> Csv.runParser $ Csv.parseField @GYTime "not a time" --- Left "can't parse 'not a time' as GYTime in ISO8601 format" --- + toField = encodeUtf8 . Text.pack . gyIso8601Show + +{- | + +>>> Csv.runParser $ Csv.parseField @GYTime "1970-01-01T00:00:00Z" +Right (GYTime 0s) + +>>> Csv.runParser $ Csv.parseField @GYTime "not a time" +Left "can't parse 'not a time' as GYTime in ISO8601 format" +-} instance Csv.FromField GYTime where - parseField = either (fail . Text.unpack) return . Web.parseUrlPiece . decodeUtf8Lenient + parseField = either (fail . Text.unpack) return . Web.parseUrlPiece . decodeUtf8Lenient getCurrentGYTime :: IO GYTime getCurrentGYTime = GYTime <$> Time.getPOSIXTime @@ -103,106 +114,107 @@ getCurrentGYTime = GYTime <$> Time.getPOSIXTime addSeconds :: GYTime -> Rational -> GYTime addSeconds (GYTime t) s = GYTime $ t + fromRational s --- | --- --- >>> timeFromPlutus 12345 --- GYTime 12.345s --- +{- | + +>>> timeFromPlutus 12345 +GYTime 12.345s +-} timeFromPlutus :: Plutus.POSIXTime -> GYTime timeFromPlutus t = GYTime $ Time.secondsToNominalDiffTime $ fromIntegral t / 1000 --- | --- --- >>> timeToPlutus $ timeFromPlutus 31415 --- POSIXTime {getPOSIXTime = 31415} --- +{- | + +>>> timeToPlutus $ timeFromPlutus 31415 +POSIXTime {getPOSIXTime = 31415} +-} timeToPlutus :: GYTime -> Plutus.POSIXTime timeToPlutus (GYTime t) = round $ 1000 * Time.nominalDiffTimeToSeconds t --- | --- --- >>> timeToPOSIX (timeFromPOSIX 12346) --- 12346s --- +{- | + +>>> timeToPOSIX (timeFromPOSIX 12346) +12346s +-} timeToPOSIX :: GYTime -> Time.POSIXTime timeToPOSIX = coerce --- | --- --- >>> timeFromPOSIX 12346 --- GYTime 12346s --- +{- | + +>>> timeFromPOSIX 12346 +GYTime 12346s +-} timeFromPOSIX :: Time.POSIXTime -> GYTime timeFromPOSIX = coerce --- | --- --- >>> gyIso8601Show (timeFromPlutus 0) --- "1970-01-01T00:00:00Z" --- +{- | + +>>> gyIso8601Show (timeFromPlutus 0) +"1970-01-01T00:00:00Z" +-} gyIso8601Show :: GYTime -> String gyIso8601Show (GYTime t) = Time.iso8601Show $ Time.posixSecondsToUTCTime t --- | --- --- >>> gyIso8601ParseM @Maybe "1970-01-01T00:00:33.333Z" --- Just (GYTime 33.333s) --- --- >>> gyIso8601ParseM @Maybe "1970-01-01T00:00:33.333" --- Nothing --- -gyIso8601ParseM :: MonadFail m => String -> m GYTime +{- | + +>>> gyIso8601ParseM @Maybe "1970-01-01T00:00:33.333Z" +Just (GYTime 33.333s) + +>>> gyIso8601ParseM @Maybe "1970-01-01T00:00:33.333" +Nothing +-} +gyIso8601ParseM :: (MonadFail m) => String -> m GYTime gyIso8601ParseM = fmap (GYTime . Time.utcTimeToPOSIXSeconds) . Time.iso8601ParseM --- | --- --- >>> printf "%s\n" $ timeFromPlutus 1000 --- 1970-01-01T00:00:01Z --- +{- | + +>>> printf "%s\n" $ timeFromPlutus 1000 +1970-01-01T00:00:01Z +-} instance PrintfArg GYTime where - formatArg = formatArg . gyIso8601Show - --- | --- --- >>> Web.parseUrlPiece @GYTime "1970-01-01T00:00:00Z" --- Right (GYTime 0s) --- --- >>> Web.parseUrlPiece @GYTime "1970-01-01T00:00:00" --- Left "can't parse '1970-01-01T00:00:00' as GYTime in ISO8601 format" --- + formatArg = formatArg . gyIso8601Show + +{- | + +>>> Web.parseUrlPiece @GYTime "1970-01-01T00:00:00Z" +Right (GYTime 0s) + +>>> Web.parseUrlPiece @GYTime "1970-01-01T00:00:00" +Left "can't parse '1970-01-01T00:00:00' as GYTime in ISO8601 format" +-} instance Web.FromHttpApiData GYTime where - parseUrlPiece t = maybe - (Left $ Text.pack $ printf "can't parse '%s' as GYTime in ISO8601 format" t) - Right - (gyIso8601ParseM $ Text.unpack t) - --- | --- --- >>> Web.toUrlPiece $ timeFromPlutus 0 --- "1970-01-01T00:00:00Z" --- + parseUrlPiece t = + maybe + (Left $ Text.pack $ printf "can't parse '%s' as GYTime in ISO8601 format" t) + Right + (gyIso8601ParseM $ Text.unpack t) + +{- | + +>>> Web.toUrlPiece $ timeFromPlutus 0 +"1970-01-01T00:00:00Z" +-} instance Web.ToHttpApiData GYTime where - toUrlPiece = Web.toUrlPiece . gyIso8601Show + toUrlPiece = Web.toUrlPiece . gyIso8601Show --- | --- --- >>> LBS8.putStrLn $ Aeson.encode $ timeFromPlutus 0 --- "1970-01-01T00:00:00Z" --- +{- | + +>>> LBS8.putStrLn $ Aeson.encode $ timeFromPlutus 0 +"1970-01-01T00:00:00Z" +-} instance Aeson.ToJSON GYTime where - toJSON = Aeson.toJSON . gyIso8601Show - --- | --- --- >>> Aeson.eitherDecode @GYTime "\"1970-01-01T00:00:00Z\"" --- Right (GYTime 0s) --- --- >>> Aeson.eitherDecode @GYTime "\"1970-01-01T00:00:00\"" --- Left "Error in $: can't parse '1970-01-01T00:00:00' as GYTime in ISO8601 format" --- + toJSON = Aeson.toJSON . gyIso8601Show + +{- | + +>>> Aeson.eitherDecode @GYTime "\"1970-01-01T00:00:00Z\"" +Right (GYTime 0s) + +>>> Aeson.eitherDecode @GYTime "\"1970-01-01T00:00:00\"" +Left "Error in $: can't parse '1970-01-01T00:00:00' as GYTime in ISO8601 format" +-} instance Aeson.FromJSON GYTime where - parseJSON v = do - s <- Aeson.parseJSON v - case gyIso8601ParseM s of - Just t -> return t - Nothing -> fail $ printf "can't parse '%s' as GYTime in ISO8601 format" s + parseJSON v = do + s <- Aeson.parseJSON v + case gyIso8601ParseM s of + Just t -> return t + Nothing -> fail $ printf "can't parse '%s' as GYTime in ISO8601 format" s diff --git a/src/GeniusYield/Types/Tx.hs b/src/GeniusYield/Types/Tx.hs index 97f7595e..fc739420 100644 --- a/src/GeniusYield/Types/Tx.hs +++ b/src/GeniusYield/Types/Tx.hs @@ -1,119 +1,130 @@ -{-| +{- | Module : GeniusYield.Types.Tx Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Types.Tx - ( -- * Docspec setup - -- $setup - - -- * Transactions - GYTx - , txFromApi - , txToApi - , txFromHex - , txFromHexBS - , txFromCBOR - , txToHex - , txToHexBS - , txToCBOR - , writeTx - -- * Transaction Id's - , GYTxId - , txIdFromHex - , txIdFromHexE - , txIdToApi - , txIdFromApi - , txIdFromPlutus - -- * Transaction Witness Set - , GYTxWitness - , txWitFromHexBS - , txWitFromHex - , txWitFromLedger - , txWitToLedger - , txWitToKeyWitnessApi +module GeniusYield.Types.Tx ( + -- * Docspec setup + -- $setup + + -- * Transactions + GYTx, + txFromApi, + txToApi, + txFromHex, + txFromHexBS, + txFromCBOR, + txToHex, + txToHexBS, + txToCBOR, + writeTx, + + -- * Transaction Id's + GYTxId, + txIdFromHex, + txIdFromHexE, + txIdToApi, + txIdFromApi, + txIdFromPlutus, + + -- * Transaction Witness Set + GYTxWitness, + txWitFromHexBS, + txWitFromHex, + txWitFromLedger, + txWitToLedger, + txWitToKeyWitnessApi, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits, - addrAlonzoTxWitsL) -import qualified Cardano.Ledger.Binary as CBOR -import Cardano.Ledger.Conway (Conway) -import qualified Cardano.Ledger.Conway as Conway (ConwayEra) -import qualified Cardano.Ledger.Crypto as Crypto -import Control.Lens (view, (?~)) -import qualified Data.Aeson.Types as Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as BS16 -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Csv as Csv -import qualified Data.Set as Set -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Database.PostgreSQL.Simple as PQ -import qualified Database.PostgreSQL.Simple.ToField as PQ -import qualified PlutusLedgerApi.V1 as PlutusV1 (TxId (..)) -import qualified PlutusLedgerApi.V3 as PlutusV3 (TxId (..)) -import qualified PlutusTx.Builtins.Internal as Plutus -import qualified Text.Printf as Printf -import qualified Web.HttpApiData as Web - -import Cardano.Ledger.Core (eraProtVerHigh) -import GeniusYield.Imports -import GeniusYield.Types.Era (ApiEra) -import GeniusYield.Types.PlutusVersion (PlutusVersion (..), - VersionIsGreater) - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Cardano.Api as Api --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.Text as Text --- >>> import qualified Data.Text.Encoding as TE --- >>> import qualified Data.ByteString as BS --- >>> import Data.Maybe (fromMaybe) --- >>> import qualified Text.Printf as Printf --- >>> --- >>> --- >>> let gyTxId = "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c" :: GYTxId --- >>> let txHexBS = "84aa00d9010282825820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e2101825820f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a0001828358391044376a5f63342097a4f20401088c62da272639e60644a9ec1d70f4441d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315821a0629c240a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f010158207caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d5758258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a3b718a25021a0005384807582037c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f209a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01010b5820a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe50dd9010281825820c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a12000108258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a004476d4111a0007d46c12d901028282582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c704826240082582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c7048262401a300d9010281825820e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c6195758409a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d0804d9010281d8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97d8799fd8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97ffd8799fd8799fd8799f581c1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315ffffffffd8799f4040ff1a05f5e1001a05f5e100d8799f581cc6e65ba7878b2f8ea0ad39287d3e2fd256dc5c4160fc19bdf4c4d87e457447454e53ffd8799f0101ff5820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01d87a80d87a80001a000f42401a000f4240d8799f1a000f42401a000493e000ff00ff05a182010082d8799fd8799fd8799f5820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21ff01ffff821a000b16161a0dd08920f5d90103a100a11902a2a1636d736781781947656e6975735969656c643a204f7264657220706c61636564" :: BS.ByteString --- >>> let tx = fromMaybe (error "Not able to convert hex string to GYTx") (txFromHex $ Text.unpack $ TE.decodeUtf8 txHexBS) --- +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Ledger.Alonzo.TxWits ( + AlonzoTxWits, + addrAlonzoTxWitsL, + ) +import Cardano.Ledger.Binary qualified as CBOR +import Cardano.Ledger.Conway (Conway) +import Cardano.Ledger.Conway qualified as Conway (ConwayEra) +import Cardano.Ledger.Crypto qualified as Crypto +import Control.Lens (view, (?~)) +import Data.Aeson.Types qualified as Aeson +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as BS16 +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.Csv qualified as Csv +import Data.Set qualified as Set +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Database.PostgreSQL.Simple qualified as PQ +import Database.PostgreSQL.Simple.ToField qualified as PQ +import PlutusLedgerApi.V1 qualified as PlutusV1 (TxId (..)) +import PlutusLedgerApi.V3 qualified as PlutusV3 (TxId (..)) +import PlutusTx.Builtins.Internal qualified as Plutus +import Text.Printf qualified as Printf +import Web.HttpApiData qualified as Web + +import Cardano.Ledger.Core (eraProtVerHigh) +import GeniusYield.Imports +import GeniusYield.Types.Era (ApiEra) +import GeniusYield.Types.PlutusVersion ( + PlutusVersion (..), + VersionIsGreater, + ) + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Cardano.Api as Api +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.Text as Text +>>> import qualified Data.Text.Encoding as TE +>>> import qualified Data.ByteString as BS +>>> import Data.Maybe (fromMaybe) +>>> import qualified Text.Printf as Printf +>>> +>>> +>>> let gyTxId = "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c" :: GYTxId +>>> let txHexBS = "84aa00d9010282825820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e2101825820f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a0001828358391044376a5f63342097a4f20401088c62da272639e60644a9ec1d70f4441d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315821a0629c240a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f010158207caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d5758258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a3b718a25021a0005384807582037c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f209a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01010b5820a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe50dd9010281825820c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a12000108258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a004476d4111a0007d46c12d901028282582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c704826240082582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c7048262401a300d9010281825820e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c6195758409a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d0804d9010281d8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97d8799fd8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97ffd8799fd8799fd8799f581c1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315ffffffffd8799f4040ff1a05f5e1001a05f5e100d8799f581cc6e65ba7878b2f8ea0ad39287d3e2fd256dc5c4160fc19bdf4c4d87e457447454e53ffd8799f0101ff5820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01d87a80d87a80001a000f42401a000f4240d8799f1a000f42401a000493e000ff00ff05a182010082d8799fd8799fd8799f5820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21ff01ffff821a000b16161a0dd08920f5d90103a100a11902a2a1636d736781781947656e6975735969656c643a204f7264657220706c61636564" :: BS.ByteString +>>> let tx = fromMaybe (error "Not able to convert hex string to GYTx") (txFromHex $ Text.unpack $ TE.decodeUtf8 txHexBS) +-} newtype GYTx = GYTx (Api.Tx ApiEra) --- | --- --- >>> txToApi <$> (Aeson.fromJSON @GYTx $ Aeson.toJSON tx) --- Success (ShelleyTx ShelleyBasedEraConway (AlonzoTx {body = TxBodyConstr ConwayTxBodyRaw {ctbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21"}) (TxIx {unTxIx = 1}),TxIn (TxId {unTxId = SafeHash "f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a"}) (TxIx {unTxIx = 0})], ctbrCollateralInputs = fromList [TxIn (TxId {unTxId = SafeHash "c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a120"}) (TxIx {unTxIx = 0})], ctbrReferenceInputs = fromList [TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 0}),TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 1})], ctbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Testnet (ScriptHashObj (ScriptHash "44376a5f63342097a4f20401088c62da272639e60644a9ec1d70f444")) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 103400000) (MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])])),DatumHash (SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"),SNothing), sizedSize = 167},Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 997296677) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}]}, ctbrCollateralReturn = SJust (Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 4486868) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}), ctbrTotalCollateral = SJust (Coin 513132), ctbrCerts = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, ctbrTxfee = Coin 342088, ctbrVldt = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, ctbrReqSignerHashes = fromList [], ctbrMint = MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])]), ctbrScriptIntegrityHash = SJust (SafeHash "a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe5"), ctbrAuxDataHash = SJust (AuxiliaryDataHash {unsafeAuxiliaryDataHash = SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"}), ctbrTxNetworkId = SNothing, ctbrVotingProcedures = VotingProcedures {unVotingProcedures = fromList []}, ctbrProposalProcedures = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrCurrentTreasuryValue = SNothing, ctbrTreasuryDonation = Coin 0} (blake2b_256: SafeHash "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c"), wits = AlonzoTxWitsRaw {atwrAddrTxWits = fromList [WitVKeyInternal {wvkKey = VKey (VerKeyEd25519DSIGN "e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c61957"), wvkSig = SignedDSIGN (SigEd25519DSIGN "9a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d08"), wvkKeyHash = KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"}, wvkBytes = "\130X \232\128y\147\217\SUB\192\&58[\234,\199Wxv\209\237<\160[x\172\SI\193\190e\183A\198\EMWX@\154\&7\NAK+\161\254[\138 &\236\160w\209\225TyX\DC2\189\200\NUL\140C\205`(\208\132\133\ACK/\145\169\128\248\143\a9\207\177v1\ETB\222\190fs\240\252\SI\251#be\155\137D\154\ESC0\164\157\b"}], atwrBootAddrTxWits = fromList [], atwrScriptTxWits = fromList [], atwrDatsTxWits = TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList [(SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575",DataConstr Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151",Constr 0 [Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151"],Constr 0 [Constr 0 [Constr 0 [B "\GS5T\225,\138\237\145\129\138\ACK\NUL\165{\234\157P\229\t\190\218Vs\135\209$s\NAK"]]]],Constr 0 [B "",B ""],I 100000000,I 100000000,Constr 0 [B "\198\230[\167\135\139/\142\160\173\&9(}>/\210V\220\\A`\252\EM\189\244\196\216~",B "tGENS"],Constr 0 [I 1,I 1],B "\183\241\229@\161\&0\183\217\SOH\f\154\216\DEL(M\145J\185u:\232F\201\181\"\DC46\bn\254_\SOH",Constr 1 [],Constr 1 [],I 0,I 1000000,I 1000000,Constr 0 [I 1000000,I 300000,I 0],I 0] (blake2b_256: SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"))]} (blake2b_256: SafeHash "f9be8c20a8c55a5c744f293db49f89505a82a2ce89ad86479f95983e044b4fe9"), atwrRdmrsTxWits = RedeemersConstr fromList [(ConwayMinting (AsIx {unAsIx = 0}),(DataConstr Constr 0 [Constr 0 [Constr 0 [B "g{2\204\166\&8x6\252S\236\&5\180\ACK\b\NUL\137<\"\237\193\225\210\SI\247LB\230z\202\RS!"],I 1]] (blake2b_256: SafeHash "63392b71d2cdffc553e10e7804c08897c9eb5a2ca6d83e647bf523796ca35741"),WrapExUnits {unWrapExUnits = ExUnits' {exUnitsMem' = 726550, exUnitsSteps' = 231770400}}))] (blake2b_256: SafeHash "df0708c4c44f7ff380ded920ebe4e51be34b100e9235df0294cb64948c047c0f")} (blake2b_256: SafeHash "0a0052247e0995d8010860a20560f5cd9faf78b057fa6cd1f367fd900f8248fa"), isValid = IsValid True, auxiliaryData = SJust (AuxiliaryDataConstr AlonzoTxAuxDataRaw {atadrMetadata = fromList [(674,Map [(S "msg",List [S "GeniusYield: Order placed"])])], atadrTimelock = StrictSeq {fromStrict = fromList []}, atadrPlutus = fromList []} (blake2b_256: SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"))})) --- +{- | + +>>> txToApi <$> (Aeson.fromJSON @GYTx $ Aeson.toJSON tx) +Success (ShelleyTx ShelleyBasedEraConway (AlonzoTx {body = TxBodyConstr ConwayTxBodyRaw {ctbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21"}) (TxIx {unTxIx = 1}),TxIn (TxId {unTxId = SafeHash "f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a"}) (TxIx {unTxIx = 0})], ctbrCollateralInputs = fromList [TxIn (TxId {unTxId = SafeHash "c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a120"}) (TxIx {unTxIx = 0})], ctbrReferenceInputs = fromList [TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 0}),TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 1})], ctbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Testnet (ScriptHashObj (ScriptHash "44376a5f63342097a4f20401088c62da272639e60644a9ec1d70f444")) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 103400000) (MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])])),DatumHash (SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"),SNothing), sizedSize = 167},Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 997296677) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}]}, ctbrCollateralReturn = SJust (Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 4486868) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}), ctbrTotalCollateral = SJust (Coin 513132), ctbrCerts = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, ctbrTxfee = Coin 342088, ctbrVldt = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, ctbrReqSignerHashes = fromList [], ctbrMint = MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])]), ctbrScriptIntegrityHash = SJust (SafeHash "a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe5"), ctbrAuxDataHash = SJust (AuxiliaryDataHash {unsafeAuxiliaryDataHash = SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"}), ctbrTxNetworkId = SNothing, ctbrVotingProcedures = VotingProcedures {unVotingProcedures = fromList []}, ctbrProposalProcedures = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrCurrentTreasuryValue = SNothing, ctbrTreasuryDonation = Coin 0} (blake2b_256: SafeHash "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c"), wits = AlonzoTxWitsRaw {atwrAddrTxWits = fromList [WitVKeyInternal {wvkKey = VKey (VerKeyEd25519DSIGN "e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c61957"), wvkSig = SignedDSIGN (SigEd25519DSIGN "9a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d08"), wvkKeyHash = KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"}, wvkBytes = "\130X \232\128y\147\217\SUB\192\&58[\234,\199Wxv\209\237<\160[x\172\SI\193\190e\183A\198\EMWX@\154\&7\NAK+\161\254[\138 &\236\160w\209\225TyX\DC2\189\200\NUL\140C\205`(\208\132\133\ACK/\145\169\128\248\143\a9\207\177v1\ETB\222\190fs\240\252\SI\251#be\155\137D\154\ESC0\164\157\b"}], atwrBootAddrTxWits = fromList [], atwrScriptTxWits = fromList [], atwrDatsTxWits = TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList [(SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575",DataConstr Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151",Constr 0 [Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151"],Constr 0 [Constr 0 [Constr 0 [B "\GS5T\225,\138\237\145\129\138\ACK\NUL\165{\234\157P\229\t\190\218Vs\135\209$s\NAK"]]]],Constr 0 [B "",B ""],I 100000000,I 100000000,Constr 0 [B "\198\230[\167\135\139/\142\160\173\&9(}>/\210V\220\\A`\252\EM\189\244\196\216~",B "tGENS"],Constr 0 [I 1,I 1],B "\183\241\229@\161\&0\183\217\SOH\f\154\216\DEL(M\145J\185u:\232F\201\181\"\DC46\bn\254_\SOH",Constr 1 [],Constr 1 [],I 0,I 1000000,I 1000000,Constr 0 [I 1000000,I 300000,I 0],I 0] (blake2b_256: SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"))]} (blake2b_256: SafeHash "f9be8c20a8c55a5c744f293db49f89505a82a2ce89ad86479f95983e044b4fe9"), atwrRdmrsTxWits = RedeemersConstr fromList [(ConwayMinting (AsIx {unAsIx = 0}),(DataConstr Constr 0 [Constr 0 [Constr 0 [B "g{2\204\166\&8x6\252S\236\&5\180\ACK\b\NUL\137<\"\237\193\225\210\SI\247LB\230z\202\RS!"],I 1]] (blake2b_256: SafeHash "63392b71d2cdffc553e10e7804c08897c9eb5a2ca6d83e647bf523796ca35741"),WrapExUnits {unWrapExUnits = ExUnits' {exUnitsMem' = 726550, exUnitsSteps' = 231770400}}))] (blake2b_256: SafeHash "df0708c4c44f7ff380ded920ebe4e51be34b100e9235df0294cb64948c047c0f")} (blake2b_256: SafeHash "0a0052247e0995d8010860a20560f5cd9faf78b057fa6cd1f367fd900f8248fa"), isValid = IsValid True, auxiliaryData = SJust (AuxiliaryDataConstr AlonzoTxAuxDataRaw {atadrMetadata = fromList [(674,Map [(S "msg",List [S "GeniusYield: Order placed"])])], atadrTimelock = StrictSeq {fromStrict = fromList []}, atadrPlutus = fromList []} (blake2b_256: SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"))})) +-} instance Aeson.FromJSON GYTx where - parseJSON = Aeson.withText "GYTx" $ \t -> do - case txFromHexBS $ TE.encodeUtf8 t of - Left err -> fail $ "Not a GYTx: " ++ err - Right tx -> return tx + parseJSON = Aeson.withText "GYTx" $ \t -> do + case txFromHexBS $ TE.encodeUtf8 t of + Left err -> fail $ "Not a GYTx: " ++ err + Right tx -> return tx --- | --- --- >>> Aeson.toJSON tx --- String "84aa00d9010282825820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e2101825820f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a0001828358391044376a5f63342097a4f20401088c62da272639e60644a9ec1d70f4441d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315821a0629c240a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f010158207caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d5758258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a3b718a25021a0005384807582037c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f209a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01010b5820a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe50dd9010281825820c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a12000108258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a004476d4111a0007d46c12d901028282582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c704826240082582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c7048262401a300d9010281825820e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c6195758409a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d0804d9010281d8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97d8799fd8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97ffd8799fd8799fd8799f581c1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315ffffffffd8799f4040ff1a05f5e1001a05f5e100d8799f581cc6e65ba7878b2f8ea0ad39287d3e2fd256dc5c4160fc19bdf4c4d87e457447454e53ffd8799f0101ff5820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01d87a80d87a80001a000f42401a000f4240d8799f1a000f42401a000493e000ff00ff05a182010082d8799fd8799fd8799f5820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21ff01ffff821a000b16161a0dd08920f5d90103a100a11902a2a1636d736781781947656e6975735969656c643a204f7264657220706c61636564" --- +{- | + +>>> Aeson.toJSON tx +String "84aa00d9010282825820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e2101825820f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a0001828358391044376a5f63342097a4f20401088c62da272639e60644a9ec1d70f4441d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315821a0629c240a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f010158207caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d5758258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a3b718a25021a0005384807582037c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f209a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01010b5820a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe50dd9010281825820c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a12000108258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a004476d4111a0007d46c12d901028282582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c704826240082582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c7048262401a300d9010281825820e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c6195758409a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d0804d9010281d8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97d8799fd8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97ffd8799fd8799fd8799f581c1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315ffffffffd8799f4040ff1a05f5e1001a05f5e100d8799f581cc6e65ba7878b2f8ea0ad39287d3e2fd256dc5c4160fc19bdf4c4d87e457447454e53ffd8799f0101ff5820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01d87a80d87a80001a000f42401a000f4240d8799f1a000f42401a000493e000ff00ff05a182010082d8799fd8799fd8799f5820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21ff01ffff821a000b16161a0dd08920f5d90103a100a11902a2a1636d736781781947656e6975735969656c643a204f7264657220706c61636564" +-} instance Aeson.ToJSON GYTx where - toJSON = Aeson.toJSON . txToHex + toJSON = Aeson.toJSON . txToHex instance Swagger.ToSchema GYTx where - declareNamedSchema _ = pure $ Swagger.named "GYTx" $ mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.example ?~ toJSON ("84a70082825820975e4c7f8d7937f8102e500714feb3f014c8766fcf287a11c10c686154fcb27501825820c887cba672004607a0f60ab28091d5c24860dbefb92b1a8776272d752846574f000d818258207a67cd033169e330c9ae9b8d0ef8b71de9eb74bbc8f3f6be90446dab7d1e8bfd00018282583900fd040c7a10744b79e5c80ec912a05dbdb3009e372b7f4b0f026d16b0c663651ffc046068455d2994564ba9d4b3e9b458ad8ab5232aebbf401a1abac7d882583900fd040c7a10744b79e5c80ec912a05dbdb3009e372b7f4b0f026d16b0c663651ffc046068455d2994564ba9d4b3e9b458ad8ab5232aebbf40821a0017ad4aa2581ca6bb5fd825455e7c69bdaa9d3a6dda9bcbe9b570bc79bd55fa50889ba1466e69636b656c1911d7581cb17cb47f51d6744ad05fb937a762848ad61674f8aebbaec67be0bb6fa14853696c6c69636f6e190258021a00072f3c0e8009a1581cb17cb47f51d6744ad05fb937a762848ad61674f8aebbaec67be0bb6fa14853696c6c69636f6e1902580b5820291b4e4c5f189cb896674e02e354028915b11889687c53d9cf4c1c710ff5e4aea203815908d45908d101000033332332232332232323232323232323232323232323232323232222223232323235500222222222225335333553024120013232123300122333500522002002001002350012200112330012253350021001102d02c25335325335333573466e3cd400488008d404c880080b40b04ccd5cd19b873500122001350132200102d02c102c3500122002102b102c00a132635335738921115554784f206e6f7420636f6e73756d65640002302115335333573466e3c048d5402c880080ac0a854cd4ccd5cd19b8701335500b2200102b02a10231326353357389210c77726f6e6720616d6f756e740002302113263533573892010b77726f6e6720746f6b656e00023021135500122222222225335330245027007162213500222253350041335502d00200122161353333573466e1cd55cea8012400046644246600200600464646464646464646464646666ae68cdc39aab9d500a480008cccccccccc888888888848cccccccccc00402c02802402001c01801401000c008cd40548c8c8cccd5cd19b8735573aa0049000119910919800801801180f1aba15002301a357426ae8940088c98d4cd5ce01381401301289aab9e5001137540026ae854028cd4054058d5d0a804999aa80c3ae501735742a010666aa030eb9405cd5d0a80399a80a80f1aba15006335015335502101f75a6ae854014c8c8c8cccd5cd19b8735573aa00490001199109198008018011919191999ab9a3370e6aae754009200023322123300100300233502475a6ae854008c094d5d09aba2500223263533573805605805405226aae7940044dd50009aba150023232323333573466e1cd55cea8012400046644246600200600466a048eb4d5d0a80118129aba135744a004464c6a66ae700ac0b00a80a44d55cf280089baa001357426ae8940088c98d4cd5ce01381401301289aab9e5001137540026ae854010cd4055d71aba15003335015335502175c40026ae854008c06cd5d09aba2500223263533573804604804404226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226aae7940044dd50009aba150023232323333573466e1d400520062321222230040053016357426aae79400c8cccd5cd19b875002480108c848888c008014c060d5d09aab9e500423333573466e1d400d20022321222230010053014357426aae7940148cccd5cd19b875004480008c848888c00c014dd71aba135573ca00c464c6a66ae7007807c07407006c0680644d55cea80089baa001357426ae8940088c98d4cd5ce00b80c00b00a9100109aab9e5001137540022464460046eb0004c8004d5406488cccd55cf8009280c119a80b98021aba100230033574400402446464646666ae68cdc39aab9d5003480008ccc88848ccc00401000c008c8c8c8cccd5cd19b8735573aa004900011991091980080180118099aba1500233500c012357426ae8940088c98d4cd5ce00b00b80a80a09aab9e5001137540026ae85400cccd5401dd728031aba1500233500875c6ae84d5d1280111931a99ab9c012013011010135744a00226aae7940044dd5000899aa800bae75a224464460046eac004c8004d5405c88c8cccd55cf8011280b919a80b19aa80c18031aab9d5002300535573ca00460086ae8800c0444d5d080089119191999ab9a3370ea0029000119091180100198029aba135573ca00646666ae68cdc3a801240044244002464c6a66ae7004004403c0380344d55cea80089baa001232323333573466e1cd55cea80124000466442466002006004600a6ae854008dd69aba135744a004464c6a66ae7003403803002c4d55cf280089baa0012323333573466e1cd55cea800a400046eb8d5d09aab9e500223263533573801601801401226ea8004488c8c8cccd5cd19b87500148010848880048cccd5cd19b875002480088c84888c00c010c018d5d09aab9e500423333573466e1d400d20002122200223263533573801c01e01a01801601426aae7540044dd50009191999ab9a3370ea0029001100911999ab9a3370ea0049000100911931a99ab9c00a00b009008007135573a6ea80048c8c8c8c8c8cccd5cd19b8750014803084888888800c8cccd5cd19b875002480288488888880108cccd5cd19b875003480208cc8848888888cc004024020dd71aba15005375a6ae84d5d1280291999ab9a3370ea00890031199109111111198010048041bae35742a00e6eb8d5d09aba2500723333573466e1d40152004233221222222233006009008300c35742a0126eb8d5d09aba2500923333573466e1d40192002232122222223007008300d357426aae79402c8cccd5cd19b875007480008c848888888c014020c038d5d09aab9e500c23263533573802402602202001e01c01a01801601426aae7540104d55cf280189aab9e5002135573ca00226ea80048c8c8c8c8cccd5cd19b875001480088ccc888488ccc00401401000cdd69aba15004375a6ae85400cdd69aba135744a00646666ae68cdc3a80124000464244600400660106ae84d55cf280311931a99ab9c00b00c00a009008135573aa00626ae8940044d55cf280089baa001232323333573466e1d400520022321223001003375c6ae84d55cf280191999ab9a3370ea004900011909118010019bae357426aae7940108c98d4cd5ce00400480380300289aab9d5001137540022244464646666ae68cdc39aab9d5002480008cd5403cc018d5d0a80118029aba135744a004464c6a66ae7002002401c0184d55cf280089baa00149924103505431001200132001355008221122253350011350032200122133350052200230040023335530071200100500400132001355007222533500110022213500222330073330080020060010033200135500622225335001100222135002225335333573466e1c005200000d00c13330080070060031333008007335009123330010080030020060031122002122122330010040031122123300100300212200212200111232300100122330033002002001482c0252210853696c6c69636f6e003351223300248920975e4c7f8d7937f8102e500714feb3f014c8766fcf287a11c10c686154fcb27500480088848cc00400c00880050581840100d87980821a001f372a1a358a2b14f5f6" :: String) - & Swagger.description ?~ "Transaction cbor hex string" + declareNamedSchema _ = + pure $ + Swagger.named "GYTx" $ + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.example + ?~ toJSON ("84a70082825820975e4c7f8d7937f8102e500714feb3f014c8766fcf287a11c10c686154fcb27501825820c887cba672004607a0f60ab28091d5c24860dbefb92b1a8776272d752846574f000d818258207a67cd033169e330c9ae9b8d0ef8b71de9eb74bbc8f3f6be90446dab7d1e8bfd00018282583900fd040c7a10744b79e5c80ec912a05dbdb3009e372b7f4b0f026d16b0c663651ffc046068455d2994564ba9d4b3e9b458ad8ab5232aebbf401a1abac7d882583900fd040c7a10744b79e5c80ec912a05dbdb3009e372b7f4b0f026d16b0c663651ffc046068455d2994564ba9d4b3e9b458ad8ab5232aebbf40821a0017ad4aa2581ca6bb5fd825455e7c69bdaa9d3a6dda9bcbe9b570bc79bd55fa50889ba1466e69636b656c1911d7581cb17cb47f51d6744ad05fb937a762848ad61674f8aebbaec67be0bb6fa14853696c6c69636f6e190258021a00072f3c0e8009a1581cb17cb47f51d6744ad05fb937a762848ad61674f8aebbaec67be0bb6fa14853696c6c69636f6e1902580b5820291b4e4c5f189cb896674e02e354028915b11889687c53d9cf4c1c710ff5e4aea203815908d45908d101000033332332232332232323232323232323232323232323232323232222223232323235500222222222225335333553024120013232123300122333500522002002001002350012200112330012253350021001102d02c25335325335333573466e3cd400488008d404c880080b40b04ccd5cd19b873500122001350132200102d02c102c3500122002102b102c00a132635335738921115554784f206e6f7420636f6e73756d65640002302115335333573466e3c048d5402c880080ac0a854cd4ccd5cd19b8701335500b2200102b02a10231326353357389210c77726f6e6720616d6f756e740002302113263533573892010b77726f6e6720746f6b656e00023021135500122222222225335330245027007162213500222253350041335502d00200122161353333573466e1cd55cea8012400046644246600200600464646464646464646464646666ae68cdc39aab9d500a480008cccccccccc888888888848cccccccccc00402c02802402001c01801401000c008cd40548c8c8cccd5cd19b8735573aa0049000119910919800801801180f1aba15002301a357426ae8940088c98d4cd5ce01381401301289aab9e5001137540026ae854028cd4054058d5d0a804999aa80c3ae501735742a010666aa030eb9405cd5d0a80399a80a80f1aba15006335015335502101f75a6ae854014c8c8c8cccd5cd19b8735573aa00490001199109198008018011919191999ab9a3370e6aae754009200023322123300100300233502475a6ae854008c094d5d09aba2500223263533573805605805405226aae7940044dd50009aba150023232323333573466e1cd55cea8012400046644246600200600466a048eb4d5d0a80118129aba135744a004464c6a66ae700ac0b00a80a44d55cf280089baa001357426ae8940088c98d4cd5ce01381401301289aab9e5001137540026ae854010cd4055d71aba15003335015335502175c40026ae854008c06cd5d09aba2500223263533573804604804404226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226aae7940044dd50009aba150023232323333573466e1d400520062321222230040053016357426aae79400c8cccd5cd19b875002480108c848888c008014c060d5d09aab9e500423333573466e1d400d20022321222230010053014357426aae7940148cccd5cd19b875004480008c848888c00c014dd71aba135573ca00c464c6a66ae7007807c07407006c0680644d55cea80089baa001357426ae8940088c98d4cd5ce00b80c00b00a9100109aab9e5001137540022464460046eb0004c8004d5406488cccd55cf8009280c119a80b98021aba100230033574400402446464646666ae68cdc39aab9d5003480008ccc88848ccc00401000c008c8c8c8cccd5cd19b8735573aa004900011991091980080180118099aba1500233500c012357426ae8940088c98d4cd5ce00b00b80a80a09aab9e5001137540026ae85400cccd5401dd728031aba1500233500875c6ae84d5d1280111931a99ab9c012013011010135744a00226aae7940044dd5000899aa800bae75a224464460046eac004c8004d5405c88c8cccd55cf8011280b919a80b19aa80c18031aab9d5002300535573ca00460086ae8800c0444d5d080089119191999ab9a3370ea0029000119091180100198029aba135573ca00646666ae68cdc3a801240044244002464c6a66ae7004004403c0380344d55cea80089baa001232323333573466e1cd55cea80124000466442466002006004600a6ae854008dd69aba135744a004464c6a66ae7003403803002c4d55cf280089baa0012323333573466e1cd55cea800a400046eb8d5d09aab9e500223263533573801601801401226ea8004488c8c8cccd5cd19b87500148010848880048cccd5cd19b875002480088c84888c00c010c018d5d09aab9e500423333573466e1d400d20002122200223263533573801c01e01a01801601426aae7540044dd50009191999ab9a3370ea0029001100911999ab9a3370ea0049000100911931a99ab9c00a00b009008007135573a6ea80048c8c8c8c8c8cccd5cd19b8750014803084888888800c8cccd5cd19b875002480288488888880108cccd5cd19b875003480208cc8848888888cc004024020dd71aba15005375a6ae84d5d1280291999ab9a3370ea00890031199109111111198010048041bae35742a00e6eb8d5d09aba2500723333573466e1d40152004233221222222233006009008300c35742a0126eb8d5d09aba2500923333573466e1d40192002232122222223007008300d357426aae79402c8cccd5cd19b875007480008c848888888c014020c038d5d09aab9e500c23263533573802402602202001e01c01a01801601426aae7540104d55cf280189aab9e5002135573ca00226ea80048c8c8c8c8cccd5cd19b875001480088ccc888488ccc00401401000cdd69aba15004375a6ae85400cdd69aba135744a00646666ae68cdc3a80124000464244600400660106ae84d55cf280311931a99ab9c00b00c00a009008135573aa00626ae8940044d55cf280089baa001232323333573466e1d400520022321223001003375c6ae84d55cf280191999ab9a3370ea004900011909118010019bae357426aae7940108c98d4cd5ce00400480380300289aab9d5001137540022244464646666ae68cdc39aab9d5002480008cd5403cc018d5d0a80118029aba135744a004464c6a66ae7002002401c0184d55cf280089baa00149924103505431001200132001355008221122253350011350032200122133350052200230040023335530071200100500400132001355007222533500110022213500222330073330080020060010033200135500622225335001100222135002225335333573466e1c005200000d00c13330080070060031333008007335009123330010080030020060031122002122122330010040031122123300100300212200212200111232300100122330033002002001482c0252210853696c6c69636f6e003351223300248920975e4c7f8d7937f8102e500714feb3f014c8766fcf287a11c10c686154fcb27500480088848cc00400c00880050581840100d87980821a001f372a1a358a2b14f5f6" :: String) + & Swagger.description + ?~ "Transaction cbor hex string" txFromApi :: Api.Tx ApiEra -> GYTx txFromApi = coerce @@ -125,32 +136,32 @@ instance Web.FromHttpApiData GYTx where parseUrlPiece t = first (T.pack . ("Not a tx, error: " ++)) $ txFromHexBS $ TE.encodeUtf8 t instance Printf.PrintfArg GYTx where - formatArg (GYTx tx) = Printf.formatArg (show tx) + formatArg (GYTx tx) = Printf.formatArg (show tx) --- | --- --- >>> txToApi <$> txFromHex (Text.unpack $ TE.decodeUtf8 txHexBS) --- Just (ShelleyTx ShelleyBasedEraConway (AlonzoTx {body = TxBodyConstr ConwayTxBodyRaw {ctbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21"}) (TxIx {unTxIx = 1}),TxIn (TxId {unTxId = SafeHash "f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a"}) (TxIx {unTxIx = 0})], ctbrCollateralInputs = fromList [TxIn (TxId {unTxId = SafeHash "c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a120"}) (TxIx {unTxIx = 0})], ctbrReferenceInputs = fromList [TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 0}),TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 1})], ctbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Testnet (ScriptHashObj (ScriptHash "44376a5f63342097a4f20401088c62da272639e60644a9ec1d70f444")) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 103400000) (MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])])),DatumHash (SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"),SNothing), sizedSize = 167},Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 997296677) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}]}, ctbrCollateralReturn = SJust (Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 4486868) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}), ctbrTotalCollateral = SJust (Coin 513132), ctbrCerts = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, ctbrTxfee = Coin 342088, ctbrVldt = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, ctbrReqSignerHashes = fromList [], ctbrMint = MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])]), ctbrScriptIntegrityHash = SJust (SafeHash "a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe5"), ctbrAuxDataHash = SJust (AuxiliaryDataHash {unsafeAuxiliaryDataHash = SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"}), ctbrTxNetworkId = SNothing, ctbrVotingProcedures = VotingProcedures {unVotingProcedures = fromList []}, ctbrProposalProcedures = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrCurrentTreasuryValue = SNothing, ctbrTreasuryDonation = Coin 0} (blake2b_256: SafeHash "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c"), wits = AlonzoTxWitsRaw {atwrAddrTxWits = fromList [WitVKeyInternal {wvkKey = VKey (VerKeyEd25519DSIGN "e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c61957"), wvkSig = SignedDSIGN (SigEd25519DSIGN "9a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d08"), wvkKeyHash = KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"}, wvkBytes = "\130X \232\128y\147\217\SUB\192\&58[\234,\199Wxv\209\237<\160[x\172\SI\193\190e\183A\198\EMWX@\154\&7\NAK+\161\254[\138 &\236\160w\209\225TyX\DC2\189\200\NUL\140C\205`(\208\132\133\ACK/\145\169\128\248\143\a9\207\177v1\ETB\222\190fs\240\252\SI\251#be\155\137D\154\ESC0\164\157\b"}], atwrBootAddrTxWits = fromList [], atwrScriptTxWits = fromList [], atwrDatsTxWits = TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList [(SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575",DataConstr Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151",Constr 0 [Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151"],Constr 0 [Constr 0 [Constr 0 [B "\GS5T\225,\138\237\145\129\138\ACK\NUL\165{\234\157P\229\t\190\218Vs\135\209$s\NAK"]]]],Constr 0 [B "",B ""],I 100000000,I 100000000,Constr 0 [B "\198\230[\167\135\139/\142\160\173\&9(}>/\210V\220\\A`\252\EM\189\244\196\216~",B "tGENS"],Constr 0 [I 1,I 1],B "\183\241\229@\161\&0\183\217\SOH\f\154\216\DEL(M\145J\185u:\232F\201\181\"\DC46\bn\254_\SOH",Constr 1 [],Constr 1 [],I 0,I 1000000,I 1000000,Constr 0 [I 1000000,I 300000,I 0],I 0] (blake2b_256: SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"))]} (blake2b_256: SafeHash "f9be8c20a8c55a5c744f293db49f89505a82a2ce89ad86479f95983e044b4fe9"), atwrRdmrsTxWits = RedeemersConstr fromList [(ConwayMinting (AsIx {unAsIx = 0}),(DataConstr Constr 0 [Constr 0 [Constr 0 [B "g{2\204\166\&8x6\252S\236\&5\180\ACK\b\NUL\137<\"\237\193\225\210\SI\247LB\230z\202\RS!"],I 1]] (blake2b_256: SafeHash "63392b71d2cdffc553e10e7804c08897c9eb5a2ca6d83e647bf523796ca35741"),WrapExUnits {unWrapExUnits = ExUnits' {exUnitsMem' = 726550, exUnitsSteps' = 231770400}}))] (blake2b_256: SafeHash "df0708c4c44f7ff380ded920ebe4e51be34b100e9235df0294cb64948c047c0f")} (blake2b_256: SafeHash "0a0052247e0995d8010860a20560f5cd9faf78b057fa6cd1f367fd900f8248fa"), isValid = IsValid True, auxiliaryData = SJust (AuxiliaryDataConstr AlonzoTxAuxDataRaw {atadrMetadata = fromList [(674,Map [(S "msg",List [S "GeniusYield: Order placed"])])], atadrTimelock = StrictSeq {fromStrict = fromList []}, atadrPlutus = fromList []} (blake2b_256: SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"))})) --- +{- | + +>>> txToApi <$> txFromHex (Text.unpack $ TE.decodeUtf8 txHexBS) +Just (ShelleyTx ShelleyBasedEraConway (AlonzoTx {body = TxBodyConstr ConwayTxBodyRaw {ctbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21"}) (TxIx {unTxIx = 1}),TxIn (TxId {unTxId = SafeHash "f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a"}) (TxIx {unTxIx = 0})], ctbrCollateralInputs = fromList [TxIn (TxId {unTxId = SafeHash "c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a120"}) (TxIx {unTxIx = 0})], ctbrReferenceInputs = fromList [TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 0}),TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 1})], ctbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Testnet (ScriptHashObj (ScriptHash "44376a5f63342097a4f20401088c62da272639e60644a9ec1d70f444")) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 103400000) (MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])])),DatumHash (SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"),SNothing), sizedSize = 167},Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 997296677) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}]}, ctbrCollateralReturn = SJust (Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 4486868) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}), ctbrTotalCollateral = SJust (Coin 513132), ctbrCerts = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, ctbrTxfee = Coin 342088, ctbrVldt = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, ctbrReqSignerHashes = fromList [], ctbrMint = MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])]), ctbrScriptIntegrityHash = SJust (SafeHash "a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe5"), ctbrAuxDataHash = SJust (AuxiliaryDataHash {unsafeAuxiliaryDataHash = SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"}), ctbrTxNetworkId = SNothing, ctbrVotingProcedures = VotingProcedures {unVotingProcedures = fromList []}, ctbrProposalProcedures = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrCurrentTreasuryValue = SNothing, ctbrTreasuryDonation = Coin 0} (blake2b_256: SafeHash "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c"), wits = AlonzoTxWitsRaw {atwrAddrTxWits = fromList [WitVKeyInternal {wvkKey = VKey (VerKeyEd25519DSIGN "e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c61957"), wvkSig = SignedDSIGN (SigEd25519DSIGN "9a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d08"), wvkKeyHash = KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"}, wvkBytes = "\130X \232\128y\147\217\SUB\192\&58[\234,\199Wxv\209\237<\160[x\172\SI\193\190e\183A\198\EMWX@\154\&7\NAK+\161\254[\138 &\236\160w\209\225TyX\DC2\189\200\NUL\140C\205`(\208\132\133\ACK/\145\169\128\248\143\a9\207\177v1\ETB\222\190fs\240\252\SI\251#be\155\137D\154\ESC0\164\157\b"}], atwrBootAddrTxWits = fromList [], atwrScriptTxWits = fromList [], atwrDatsTxWits = TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList [(SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575",DataConstr Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151",Constr 0 [Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151"],Constr 0 [Constr 0 [Constr 0 [B "\GS5T\225,\138\237\145\129\138\ACK\NUL\165{\234\157P\229\t\190\218Vs\135\209$s\NAK"]]]],Constr 0 [B "",B ""],I 100000000,I 100000000,Constr 0 [B "\198\230[\167\135\139/\142\160\173\&9(}>/\210V\220\\A`\252\EM\189\244\196\216~",B "tGENS"],Constr 0 [I 1,I 1],B "\183\241\229@\161\&0\183\217\SOH\f\154\216\DEL(M\145J\185u:\232F\201\181\"\DC46\bn\254_\SOH",Constr 1 [],Constr 1 [],I 0,I 1000000,I 1000000,Constr 0 [I 1000000,I 300000,I 0],I 0] (blake2b_256: SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"))]} (blake2b_256: SafeHash "f9be8c20a8c55a5c744f293db49f89505a82a2ce89ad86479f95983e044b4fe9"), atwrRdmrsTxWits = RedeemersConstr fromList [(ConwayMinting (AsIx {unAsIx = 0}),(DataConstr Constr 0 [Constr 0 [Constr 0 [B "g{2\204\166\&8x6\252S\236\&5\180\ACK\b\NUL\137<\"\237\193\225\210\SI\247LB\230z\202\RS!"],I 1]] (blake2b_256: SafeHash "63392b71d2cdffc553e10e7804c08897c9eb5a2ca6d83e647bf523796ca35741"),WrapExUnits {unWrapExUnits = ExUnits' {exUnitsMem' = 726550, exUnitsSteps' = 231770400}}))] (blake2b_256: SafeHash "df0708c4c44f7ff380ded920ebe4e51be34b100e9235df0294cb64948c047c0f")} (blake2b_256: SafeHash "0a0052247e0995d8010860a20560f5cd9faf78b057fa6cd1f367fd900f8248fa"), isValid = IsValid True, auxiliaryData = SJust (AuxiliaryDataConstr AlonzoTxAuxDataRaw {atadrMetadata = fromList [(674,Map [(S "msg",List [S "GeniusYield: Order placed"])])], atadrTimelock = StrictSeq {fromStrict = fromList []}, atadrPlutus = fromList []} (blake2b_256: SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"))})) +-} txFromHex :: String -> Maybe GYTx txFromHex s = rightToMaybe $ txFromHexBS $ BS8.pack s --- | --- --- >>> txToApi <$> txFromHexBS txHexBS --- Right (ShelleyTx ShelleyBasedEraConway (AlonzoTx {body = TxBodyConstr ConwayTxBodyRaw {ctbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21"}) (TxIx {unTxIx = 1}),TxIn (TxId {unTxId = SafeHash "f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a"}) (TxIx {unTxIx = 0})], ctbrCollateralInputs = fromList [TxIn (TxId {unTxId = SafeHash "c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a120"}) (TxIx {unTxIx = 0})], ctbrReferenceInputs = fromList [TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 0}),TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 1})], ctbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Testnet (ScriptHashObj (ScriptHash "44376a5f63342097a4f20401088c62da272639e60644a9ec1d70f444")) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 103400000) (MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])])),DatumHash (SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"),SNothing), sizedSize = 167},Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 997296677) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}]}, ctbrCollateralReturn = SJust (Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 4486868) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}), ctbrTotalCollateral = SJust (Coin 513132), ctbrCerts = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, ctbrTxfee = Coin 342088, ctbrVldt = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, ctbrReqSignerHashes = fromList [], ctbrMint = MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])]), ctbrScriptIntegrityHash = SJust (SafeHash "a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe5"), ctbrAuxDataHash = SJust (AuxiliaryDataHash {unsafeAuxiliaryDataHash = SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"}), ctbrTxNetworkId = SNothing, ctbrVotingProcedures = VotingProcedures {unVotingProcedures = fromList []}, ctbrProposalProcedures = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrCurrentTreasuryValue = SNothing, ctbrTreasuryDonation = Coin 0} (blake2b_256: SafeHash "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c"), wits = AlonzoTxWitsRaw {atwrAddrTxWits = fromList [WitVKeyInternal {wvkKey = VKey (VerKeyEd25519DSIGN "e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c61957"), wvkSig = SignedDSIGN (SigEd25519DSIGN "9a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d08"), wvkKeyHash = KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"}, wvkBytes = "\130X \232\128y\147\217\SUB\192\&58[\234,\199Wxv\209\237<\160[x\172\SI\193\190e\183A\198\EMWX@\154\&7\NAK+\161\254[\138 &\236\160w\209\225TyX\DC2\189\200\NUL\140C\205`(\208\132\133\ACK/\145\169\128\248\143\a9\207\177v1\ETB\222\190fs\240\252\SI\251#be\155\137D\154\ESC0\164\157\b"}], atwrBootAddrTxWits = fromList [], atwrScriptTxWits = fromList [], atwrDatsTxWits = TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList [(SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575",DataConstr Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151",Constr 0 [Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151"],Constr 0 [Constr 0 [Constr 0 [B "\GS5T\225,\138\237\145\129\138\ACK\NUL\165{\234\157P\229\t\190\218Vs\135\209$s\NAK"]]]],Constr 0 [B "",B ""],I 100000000,I 100000000,Constr 0 [B "\198\230[\167\135\139/\142\160\173\&9(}>/\210V\220\\A`\252\EM\189\244\196\216~",B "tGENS"],Constr 0 [I 1,I 1],B "\183\241\229@\161\&0\183\217\SOH\f\154\216\DEL(M\145J\185u:\232F\201\181\"\DC46\bn\254_\SOH",Constr 1 [],Constr 1 [],I 0,I 1000000,I 1000000,Constr 0 [I 1000000,I 300000,I 0],I 0] (blake2b_256: SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"))]} (blake2b_256: SafeHash "f9be8c20a8c55a5c744f293db49f89505a82a2ce89ad86479f95983e044b4fe9"), atwrRdmrsTxWits = RedeemersConstr fromList [(ConwayMinting (AsIx {unAsIx = 0}),(DataConstr Constr 0 [Constr 0 [Constr 0 [B "g{2\204\166\&8x6\252S\236\&5\180\ACK\b\NUL\137<\"\237\193\225\210\SI\247LB\230z\202\RS!"],I 1]] (blake2b_256: SafeHash "63392b71d2cdffc553e10e7804c08897c9eb5a2ca6d83e647bf523796ca35741"),WrapExUnits {unWrapExUnits = ExUnits' {exUnitsMem' = 726550, exUnitsSteps' = 231770400}}))] (blake2b_256: SafeHash "df0708c4c44f7ff380ded920ebe4e51be34b100e9235df0294cb64948c047c0f")} (blake2b_256: SafeHash "0a0052247e0995d8010860a20560f5cd9faf78b057fa6cd1f367fd900f8248fa"), isValid = IsValid True, auxiliaryData = SJust (AuxiliaryDataConstr AlonzoTxAuxDataRaw {atadrMetadata = fromList [(674,Map [(S "msg",List [S "GeniusYield: Order placed"])])], atadrTimelock = StrictSeq {fromStrict = fromList []}, atadrPlutus = fromList []} (blake2b_256: SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"))})) --- +{- | + +>>> txToApi <$> txFromHexBS txHexBS +Right (ShelleyTx ShelleyBasedEraConway (AlonzoTx {body = TxBodyConstr ConwayTxBodyRaw {ctbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21"}) (TxIx {unTxIx = 1}),TxIn (TxId {unTxId = SafeHash "f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a"}) (TxIx {unTxIx = 0})], ctbrCollateralInputs = fromList [TxIn (TxId {unTxId = SafeHash "c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a120"}) (TxIx {unTxIx = 0})], ctbrReferenceInputs = fromList [TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 0}),TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 1})], ctbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Testnet (ScriptHashObj (ScriptHash "44376a5f63342097a4f20401088c62da272639e60644a9ec1d70f444")) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 103400000) (MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])])),DatumHash (SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"),SNothing), sizedSize = 167},Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 997296677) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}]}, ctbrCollateralReturn = SJust (Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 4486868) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}), ctbrTotalCollateral = SJust (Coin 513132), ctbrCerts = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, ctbrTxfee = Coin 342088, ctbrVldt = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, ctbrReqSignerHashes = fromList [], ctbrMint = MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])]), ctbrScriptIntegrityHash = SJust (SafeHash "a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe5"), ctbrAuxDataHash = SJust (AuxiliaryDataHash {unsafeAuxiliaryDataHash = SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"}), ctbrTxNetworkId = SNothing, ctbrVotingProcedures = VotingProcedures {unVotingProcedures = fromList []}, ctbrProposalProcedures = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrCurrentTreasuryValue = SNothing, ctbrTreasuryDonation = Coin 0} (blake2b_256: SafeHash "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c"), wits = AlonzoTxWitsRaw {atwrAddrTxWits = fromList [WitVKeyInternal {wvkKey = VKey (VerKeyEd25519DSIGN "e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c61957"), wvkSig = SignedDSIGN (SigEd25519DSIGN "9a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d08"), wvkKeyHash = KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"}, wvkBytes = "\130X \232\128y\147\217\SUB\192\&58[\234,\199Wxv\209\237<\160[x\172\SI\193\190e\183A\198\EMWX@\154\&7\NAK+\161\254[\138 &\236\160w\209\225TyX\DC2\189\200\NUL\140C\205`(\208\132\133\ACK/\145\169\128\248\143\a9\207\177v1\ETB\222\190fs\240\252\SI\251#be\155\137D\154\ESC0\164\157\b"}], atwrBootAddrTxWits = fromList [], atwrScriptTxWits = fromList [], atwrDatsTxWits = TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList [(SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575",DataConstr Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151",Constr 0 [Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151"],Constr 0 [Constr 0 [Constr 0 [B "\GS5T\225,\138\237\145\129\138\ACK\NUL\165{\234\157P\229\t\190\218Vs\135\209$s\NAK"]]]],Constr 0 [B "",B ""],I 100000000,I 100000000,Constr 0 [B "\198\230[\167\135\139/\142\160\173\&9(}>/\210V\220\\A`\252\EM\189\244\196\216~",B "tGENS"],Constr 0 [I 1,I 1],B "\183\241\229@\161\&0\183\217\SOH\f\154\216\DEL(M\145J\185u:\232F\201\181\"\DC46\bn\254_\SOH",Constr 1 [],Constr 1 [],I 0,I 1000000,I 1000000,Constr 0 [I 1000000,I 300000,I 0],I 0] (blake2b_256: SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"))]} (blake2b_256: SafeHash "f9be8c20a8c55a5c744f293db49f89505a82a2ce89ad86479f95983e044b4fe9"), atwrRdmrsTxWits = RedeemersConstr fromList [(ConwayMinting (AsIx {unAsIx = 0}),(DataConstr Constr 0 [Constr 0 [Constr 0 [B "g{2\204\166\&8x6\252S\236\&5\180\ACK\b\NUL\137<\"\237\193\225\210\SI\247LB\230z\202\RS!"],I 1]] (blake2b_256: SafeHash "63392b71d2cdffc553e10e7804c08897c9eb5a2ca6d83e647bf523796ca35741"),WrapExUnits {unWrapExUnits = ExUnits' {exUnitsMem' = 726550, exUnitsSteps' = 231770400}}))] (blake2b_256: SafeHash "df0708c4c44f7ff380ded920ebe4e51be34b100e9235df0294cb64948c047c0f")} (blake2b_256: SafeHash "0a0052247e0995d8010860a20560f5cd9faf78b057fa6cd1f367fd900f8248fa"), isValid = IsValid True, auxiliaryData = SJust (AuxiliaryDataConstr AlonzoTxAuxDataRaw {atadrMetadata = fromList [(674,Map [(S "msg",List [S "GeniusYield: Order placed"])])], atadrTimelock = StrictSeq {fromStrict = fromList []}, atadrPlutus = fromList []} (blake2b_256: SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"))})) +-} txFromHexBS :: BS.ByteString -> Either String GYTx txFromHexBS bs = BS16.decode bs >>= txFromCBOR txFromCBOR :: BS.ByteString -> Either String GYTx txFromCBOR = fmap txFromApi . first show . Api.deserialiseFromCBOR (Api.AsTx Api.AsConwayEra) --- | --- --- >>> txToHexBS tx == txHexBS --- True --- +{- | + +>>> txToHexBS tx == txHexBS +True +-} txToHexBS :: GYTx -> BS.ByteString txToHexBS = BS16.encode . txToCBOR @@ -158,22 +169,22 @@ txToHexBS = BS16.encode . txToCBOR txToCBOR :: GYTx -> BS.ByteString txToCBOR = Api.serialiseToCBOR . txToApi --- | --- --- >>> txToHex tx --- "84aa00d9010282825820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e2101825820f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a0001828358391044376a5f63342097a4f20401088c62da272639e60644a9ec1d70f4441d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315821a0629c240a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f010158207caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d5758258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a3b718a25021a0005384807582037c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f209a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01010b5820a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe50dd9010281825820c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a12000108258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a004476d4111a0007d46c12d901028282582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c704826240082582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c7048262401a300d9010281825820e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c6195758409a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d0804d9010281d8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97d8799fd8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97ffd8799fd8799fd8799f581c1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315ffffffffd8799f4040ff1a05f5e1001a05f5e100d8799f581cc6e65ba7878b2f8ea0ad39287d3e2fd256dc5c4160fc19bdf4c4d87e457447454e53ffd8799f0101ff5820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01d87a80d87a80001a000f42401a000f4240d8799f1a000f42401a000493e000ff00ff05a182010082d8799fd8799fd8799f5820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21ff01ffff821a000b16161a0dd08920f5d90103a100a11902a2a1636d736781781947656e6975735969656c643a204f7264657220706c61636564" --- >>> txToHex tx == (Text.unpack $ TE.decodeUtf8 txHexBS) --- True --- +{- | + +>>> txToHex tx +"84aa00d9010282825820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e2101825820f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a0001828358391044376a5f63342097a4f20401088c62da272639e60644a9ec1d70f4441d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315821a0629c240a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f010158207caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d5758258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a3b718a25021a0005384807582037c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f209a1581c53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8a15820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01010b5820a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe50dd9010281825820c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a12000108258390099f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa971d3554e12c8aed91818a0600a57bea9d50e509beda567387d12473151a004476d4111a0007d46c12d901028282582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c704826240082582016647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c7048262401a300d9010281825820e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c6195758409a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d0804d9010281d8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97d8799fd8799f581c99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97ffd8799fd8799fd8799f581c1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315ffffffffd8799f4040ff1a05f5e1001a05f5e100d8799f581cc6e65ba7878b2f8ea0ad39287d3e2fd256dc5c4160fc19bdf4c4d87e457447454e53ffd8799f0101ff5820b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01d87a80d87a80001a000f42401a000f4240d8799f1a000f42401a000493e000ff00ff05a182010082d8799fd8799fd8799f5820677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21ff01ffff821a000b16161a0dd08920f5d90103a100a11902a2a1636d736781781947656e6975735969656c643a204f7264657220706c61636564" +>>> txToHex tx == (Text.unpack $ TE.decodeUtf8 txHexBS) +True +-} txToHex :: GYTx -> String txToHex = BS8.unpack . txToHexBS writeTx :: FilePath -> GYTx -> IO () writeTx file tx = do - e <- Api.writeFileTextEnvelope (Api.File file) Nothing (txToApi tx) - case e of - Left err -> ioError $ userError $ show err - Right () -> pure () + e <- Api.writeFileTextEnvelope (Api.File file) Nothing (txToApi tx) + case e of + Left err -> ioError $ userError $ show err + Right () -> pure () data PlutusTxId (v :: PlutusVersion) where PlutusTxIdBeforeV3 :: (PlutusV3 `VersionIsGreater` v) => PlutusV1.TxId -> PlutusTxId v @@ -181,64 +192,73 @@ data PlutusTxId (v :: PlutusVersion) where -- | Transaction hash/id of a particular transaction. newtype GYTxId = GYTxId Api.TxId - deriving (Eq, Ord) - deriving newtype (FromJSON) -- TODO: Also derive ToJSON? + deriving (Eq, Ord) + deriving newtype (FromJSON) -- TODO: Also derive ToJSON? instance PQ.ToField GYTxId where - toField (GYTxId txId) = PQ.toField (PQ.Binary (Api.serialiseToRawBytes txId)) + toField (GYTxId txId) = PQ.toField (PQ.Binary (Api.serialiseToRawBytes txId)) --- | --- --- >>> show gyTxId --- "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c" --- +{- | + +>>> show gyTxId +"dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c" +-} instance Show GYTxId where - show (GYTxId txid) = T.unpack - $ TE.decodeUtf8 - $ Api.serialiseToRawBytesHex txid + show (GYTxId txid) = + T.unpack $ + TE.decodeUtf8 $ + Api.serialiseToRawBytesHex txid --- | --- --- >>> "6c751d3e198c5608dfafdfdffe16aeac8a28f88f3a769cf22dd45e8bc84f47e8" :: GYTxId --- 6c751d3e198c5608dfafdfdffe16aeac8a28f88f3a769cf22dd45e8bc84f47e8 --- +{- | + +>>> "6c751d3e198c5608dfafdfdffe16aeac8a28f88f3a769cf22dd45e8bc84f47e8" :: GYTxId +6c751d3e198c5608dfafdfdffe16aeac8a28f88f3a769cf22dd45e8bc84f47e8 +-} instance IsString GYTxId where fromString = either error id . txIdFromHexE --- | --- --- >>> Aeson.toJSON gyTxId --- String "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c" --- -instance ToJSON GYTxId where - toJSON (GYTxId txid) = Aeson.String - $ TE.decodeUtf8 - $ Api.serialiseToRawBytesHex txid +{- | +>>> Aeson.toJSON gyTxId +String "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c" +-} +instance ToJSON GYTxId where + toJSON (GYTxId txid) = + Aeson.String $ + TE.decodeUtf8 $ + Api.serialiseToRawBytesHex txid instance Swagger.ToSchema GYTxId where - declareNamedSchema _ = pure $ Swagger.named "GYTxId" $ mempty - & Swagger.example ?~ toJSON ("a8d75b90a052302c1232bedd626720966b1697fe38de556c617c340233688935" :: Text) - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.description ?~ "Transaction id" --- --- | --- --- >>> Printf.printf "tid = %s" gyTxId --- tid = dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c + declareNamedSchema _ = + pure $ + Swagger.named "GYTxId" $ + mempty + & Swagger.example + ?~ toJSON ("a8d75b90a052302c1232bedd626720966b1697fe38de556c617c340233688935" :: Text) + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.description + ?~ "Transaction id" + -- + +{- | + +>>> Printf.printf "tid = %s" gyTxId +tid = dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c +-} instance Printf.PrintfArg GYTxId where - formatArg tid = Printf.formatArg (show tid) + formatArg tid = Printf.formatArg (show tid) instance Csv.FromField GYTxId where - parseField f = do - s <- Csv.parseField f - case txIdFromHexE s of - Left err -> fail err - Right tid -> return tid + parseField f = do + s <- Csv.parseField f + case txIdFromHexE s of + Left err -> fail err + Right tid -> return tid instance Csv.ToField GYTxId where - toField = Csv.toField . show + toField = Csv.toField . show txIdFromHex :: String -> Maybe GYTxId txIdFromHex = rightToMaybe . txIdFromHexE @@ -258,19 +278,23 @@ txIdFromPlutus (PlutusTxIdV3 (PlutusV3.TxId (Plutus.BuiltinByteString bs))) = tx -- | Wrapper around transaction witness set. Note that Babbage ledger also uses the same @TxWitness@ type defined in Alonzo ledger, which was updated for Plutus-V2 scripts and same is expected for Plutus-V3. newtype GYTxWitness = GYTxWitness (AlonzoTxWits (Conway.ConwayEra Crypto.StandardCrypto)) - deriving newtype Show + deriving newtype (Show) instance Swagger.ToSchema GYTxWitness where - declareNamedSchema _ = pure $ Swagger.named "GYTxWitness" $ mempty - & Swagger.type_ ?~ Swagger.SwaggerString + declareNamedSchema _ = + pure $ + Swagger.named "GYTxWitness" $ + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString instance Printf.PrintfArg GYTxWitness where - formatArg (GYTxWitness txWit) = Printf.formatArg (show txWit) + formatArg (GYTxWitness txWit) = Printf.formatArg (show txWit) instance Aeson.FromJSON GYTxWitness where parseJSON = Aeson.withText "GYTxWitness" $ \t -> do case txWitFromHexBS $ TE.encodeUtf8 t of - Left err -> fail $ "Not a GYTxWitness: " ++ err + Left err -> fail $ "Not a GYTxWitness: " ++ err Right txWit -> return txWit instance Web.FromHttpApiData GYTxWitness where diff --git a/src/GeniusYield/Types/TxBody.hs b/src/GeniusYield/Types/TxBody.hs index 9bb63368..61bc8313 100644 --- a/src/GeniusYield/Types/TxBody.hs +++ b/src/GeniusYield/Types/TxBody.hs @@ -1,74 +1,77 @@ -{-| +{- | Module : GeniusYield.Types.TxBody Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.TxBody ( - -- * Transaction body - GYTxBody, - -- * Conversions - txBodyFromApi, - txBodyToApi, - -- * Transaction creation - signGYTxBody, - signGYTxBody', - signTx, - unsignedTx, - makeSignedTransaction, - makeSignedTransaction', - appendWitnessGYTx, - signGYTx, - signGYTx', - -- * Functions - txBodyFromHex, - txBodyFromHexBS, - txBodyFromCBOR, - txBodyToHex, - txBodyToHexBS, - txBodyFee, - txBodyFeeValue, - txBodyUTxOs, - txBodyTxIns, - txBodyTxInsReference, - txBodyTxId, - txBodyToApiTxBodyContent, - txBodyReqSignatories, - txBodyMintValue, - txBodyValidityRange, - txBodyCollateral, - txBodyCollateralReturnOutput, - txBodyCollateralReturnOutputValue, - txBodyTotalCollateralLovelace, - getTxBody, + -- * Transaction body + GYTxBody, + + -- * Conversions + txBodyFromApi, + txBodyToApi, + + -- * Transaction creation + signGYTxBody, + signGYTxBody', + signTx, + unsignedTx, + makeSignedTransaction, + makeSignedTransaction', + appendWitnessGYTx, + signGYTx, + signGYTx', + + -- * Functions + txBodyFromHex, + txBodyFromHexBS, + txBodyFromCBOR, + txBodyToHex, + txBodyToHexBS, + txBodyFee, + txBodyFeeValue, + txBodyUTxOs, + txBodyTxIns, + txBodyTxInsReference, + txBodyTxId, + txBodyToApiTxBodyContent, + txBodyReqSignatories, + txBodyMintValue, + txBodyValidityRange, + txBodyCollateral, + txBodyCollateralReturnOutput, + txBodyCollateralReturnOutputValue, + txBodyTotalCollateralLovelace, + getTxBody, ) where - -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import qualified Cardano.Ledger.Coin as Ledger -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as BS16 -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Set as Set - -import GeniusYield.Imports -import GeniusYield.Types.Era -import GeniusYield.Types.Key (GYSomeSigningKey (GYSomeSigningKey)) -import GeniusYield.Types.Key.Class (ToShelleyWitnessSigningKey, - toShelleyWitnessSigningKey) -import GeniusYield.Types.PubKeyHash (GYPubKeyHash, pubKeyHashFromApi) -import GeniusYield.Types.Slot -import GeniusYield.Types.Tx -import GeniusYield.Types.TxOutRef -import GeniusYield.Types.UTxO -import GeniusYield.Types.Value +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Ledger.Coin qualified as Ledger +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as BS16 +import Data.ByteString.Char8 qualified as BS8 +import Data.Set qualified as Set + +import GeniusYield.Imports +import GeniusYield.Types.Era +import GeniusYield.Types.Key (GYSomeSigningKey (GYSomeSigningKey)) +import GeniusYield.Types.Key.Class ( + ToShelleyWitnessSigningKey, + toShelleyWitnessSigningKey, + ) +import GeniusYield.Types.PubKeyHash (GYPubKeyHash, pubKeyHashFromApi) +import GeniusYield.Types.Slot +import GeniusYield.Types.Tx +import GeniusYield.Types.TxOutRef +import GeniusYield.Types.UTxO +import GeniusYield.Types.Value -- | Transaction body: the part which is then signed. newtype GYTxBody = GYTxBody (Api.TxBody ApiEra) - deriving Show + deriving (Show) txBodyFromApi :: Api.TxBody ApiEra -> GYTxBody txBodyFromApi = coerce @@ -77,24 +80,26 @@ txBodyToApi :: GYTxBody -> Api.TxBody ApiEra txBodyToApi = coerce -- | Sign a transaction body with (potentially) multiple keys. -signGYTxBody :: ToShelleyWitnessSigningKey a => GYTxBody -> [a] -> GYTx +signGYTxBody :: (ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> GYTx signGYTxBody = signTx {-# DEPRECATED signTx "Use signGYTxBody." #-} -signTx :: ToShelleyWitnessSigningKey a => GYTxBody -> [a] -> GYTx -signTx (GYTxBody txBody) skeys = txFromApi - $ Api.signShelleyTransaction +signTx :: (ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> GYTx +signTx (GYTxBody txBody) skeys = + txFromApi + $ Api.signShelleyTransaction Api.ShelleyBasedEraConway txBody - $ map toShelleyWitnessSigningKey skeys + $ map toShelleyWitnessSigningKey skeys -- | Sign a transaction body with (potentially) multiple keys of potentially different nature. signGYTxBody' :: GYTxBody -> [GYSomeSigningKey] -> GYTx -signGYTxBody' (txBodyToApi -> txBody) skeys = txFromApi - $ Api.signShelleyTransaction +signGYTxBody' (txBodyToApi -> txBody) skeys = + txFromApi + $ Api.signShelleyTransaction Api.ShelleyBasedEraConway txBody - $ map (\(GYSomeSigningKey a) -> toShelleyWitnessSigningKey a) skeys + $ map (\(GYSomeSigningKey a) -> toShelleyWitnessSigningKey a) skeys -- | Make a signed transaction given the transaction body & list of key witnesses, represented in `GYTxWitness`. makeSignedTransaction :: GYTxWitness -> GYTxBody -> GYTx @@ -112,10 +117,10 @@ appendWitnessGYTx = appendWitnessGYTx' . txWitToKeyWitnessApi appendWitnessGYTx' :: [Api.S.KeyWitness ApiEra] -> GYTx -> GYTx appendWitnessGYTx' appendKeyWitnessList previousTx = let (txBody, previousKeyWitnessesList) = Api.S.getTxBodyAndWitnesses $ txToApi previousTx - in makeSignedTransaction' (previousKeyWitnessesList ++ appendKeyWitnessList) txBody + in makeSignedTransaction' (previousKeyWitnessesList ++ appendKeyWitnessList) txBody -- | Sign a transaction with (potentially) multiple keys and add your witness(s) among previous key witnesses, if any. -signGYTx :: ToShelleyWitnessSigningKey a => GYTx -> [a] -> GYTx +signGYTx :: (ToShelleyWitnessSigningKey a) => GYTx -> [a] -> GYTx signGYTx previousTx skeys = signGYTx'' previousTx $ map toShelleyWitnessSigningKey skeys -- | Sign a transaction with (potentially) multiple keys and add your witness(s) among previous key witnesses, if any. @@ -126,7 +131,7 @@ signGYTx'' previousTx skeys = -- required here to get for `appendKeyWitnessList`. let (txBody, previousKeyWitnessesList) = Api.S.getTxBodyAndWitnesses $ txToApi previousTx appendKeyWitnessList = map (Api.makeShelleyKeyWitness Api.ShelleyBasedEraConway txBody) skeys - in makeSignedTransaction' (previousKeyWitnessesList ++ appendKeyWitnessList) txBody + in makeSignedTransaction' (previousKeyWitnessesList ++ appendKeyWitnessList) txBody -- | Sign a transaction with (potentially) multiple keys of potentially different nature and add your witness(s) among previous key witnesses, if any. signGYTx' :: GYTx -> [GYSomeSigningKey] -> GYTx @@ -162,9 +167,9 @@ txBodyToCBOR = Api.serialiseToCBOR . txBodyToApi -- | Return the fees in lovelace. txBodyFee :: GYTxBody -> Integer -txBodyFee (GYTxBody (Api.TxBody Api.TxBodyContent { Api.txFee = fee })) = - case fee of - Api.TxFeeExplicit _ (Ledger.Coin actual) -> actual +txBodyFee (GYTxBody (Api.TxBody Api.TxBodyContent {Api.txFee = fee})) = + case fee of + Api.TxFeeExplicit _ (Ledger.Coin actual) -> actual -- | Return the fees as 'GYValue'. txBodyFeeValue :: GYTxBody -> GYValue @@ -173,7 +178,7 @@ txBodyFeeValue = valueFromLovelace . txBodyFee -- | Return utxos created by tx (body). txBodyUTxOs :: GYTxBody -> GYUTxOs txBodyUTxOs (GYTxBody body@(Api.TxBody Api.TxBodyContent {txOuts})) = - utxosFromList $ zipWith f [0..] txOuts + utxosFromList $ zipWith f [0 ..] txOuts where txId = Api.getTxId body @@ -187,7 +192,7 @@ txBodyTxIns (GYTxBody (Api.TxBody Api.TxBodyContent {txIns})) = map (txOutRefFro -- | Returns the 'GYTxOutRef' for the reference inputs present in the tx. txBodyTxInsReference :: GYTxBody -> [GYTxOutRef] txBodyTxInsReference (GYTxBody (Api.TxBody Api.TxBodyContent {txInsReference})) = case txInsReference of - Api.TxInsReferenceNone -> [] + Api.TxInsReferenceNone -> [] Api.TxInsReference Api.S.BabbageEraOnwardsConway inRefs -> map txOutRefFromApi inRefs -- | Returns the 'GYTxId' of the given 'GYTxBody'. @@ -209,38 +214,38 @@ txBodyReqSignatories body = case Api.txExtraKeyWits $ txBodyToApiTxBodyContent b -- | Returns the mint 'GYValue' of the given 'GYTxBody'. txBodyMintValue :: GYTxBody -> GYValue -txBodyMintValue body = case Api.txMintValue $ txBodyToApiTxBodyContent body of - Api.TxMintNone -> mempty - Api.TxMintValue _ v _ -> valueFromApi v +txBodyMintValue body = case Api.txMintValue $ txBodyToApiTxBodyContent body of + Api.TxMintNone -> mempty + Api.TxMintValue _ v _ -> valueFromApi v -- | Returns the validity range of the given 'GYTxBody'. txBodyValidityRange :: GYTxBody -> (Maybe GYSlot, Maybe GYSlot) txBodyValidityRange body = let cnt = txBodyToApiTxBodyContent body - in case (Api.txValidityLowerBound cnt, Api.txValidityUpperBound cnt) of - (lb, ub) -> (f lb, g ub) + in case (Api.txValidityLowerBound cnt, Api.txValidityUpperBound cnt) of + (lb, ub) -> (f lb, g ub) where f :: Api.TxValidityLowerBound ApiEra -> Maybe GYSlot - f Api.TxValidityNoLowerBound = Nothing + f Api.TxValidityNoLowerBound = Nothing f (Api.TxValidityLowerBound _ sn) = Just $ slotFromApi sn g :: Api.TxValidityUpperBound ApiEra -> Maybe GYSlot - g (Api.TxValidityUpperBound _ Nothing) = Nothing + g (Api.TxValidityUpperBound _ Nothing) = Nothing g (Api.TxValidityUpperBound _ (Just sn)) = Just $ slotFromApi sn -- | Returns the set of 'GYTxOutRef' used as collateral in the given 'GYTxBody'. txBodyCollateral :: GYTxBody -> Set GYTxOutRef txBodyCollateral body = case Api.txInsCollateral $ txBodyToApiTxBodyContent body of - Api.TxInsCollateralNone -> Set.empty - Api.TxInsCollateral _ xs -> Set.fromList $ txOutRefFromApi <$> xs + Api.TxInsCollateralNone -> Set.empty + Api.TxInsCollateral _ xs -> Set.fromList $ txOutRefFromApi <$> xs -- | Returns the total collateral for the given transaction body. txBodyTotalCollateralLovelace :: GYTxBody -> Natural txBodyTotalCollateralLovelace body = case Api.txTotalCollateral $ txBodyToApiTxBodyContent body of - Api.TxTotalCollateralNone -> 0 - Api.TxTotalCollateral _ (Ledger.Coin l) - | l >= 0 -> fromInteger l - | otherwise -> error $ "negative total collateral: " <> show l + Api.TxTotalCollateralNone -> 0 + Api.TxTotalCollateral _ (Ledger.Coin l) + | l >= 0 -> fromInteger l + | otherwise -> error $ "negative total collateral: " <> show l txBodyCollateralReturnOutput :: GYTxBody -> Api.TxReturnCollateral Api.CtxTx ApiEra txBodyCollateralReturnOutput body = Api.txReturnCollateral $ txBodyToApiTxBodyContent body @@ -248,5 +253,5 @@ txBodyCollateralReturnOutput body = Api.txReturnCollateral $ txBodyToApiTxBodyCo txBodyCollateralReturnOutputValue :: GYTxBody -> GYValue txBodyCollateralReturnOutputValue body = case Api.txReturnCollateral $ txBodyToApiTxBodyContent body of - Api.TxReturnCollateralNone -> mempty + Api.TxReturnCollateralNone -> mempty Api.TxReturnCollateral _ (Api.TxOut _ v _ _) -> valueFromApi $ Api.txOutValueToValue v diff --git a/src/GeniusYield/Types/TxCert.hs b/src/GeniusYield/Types/TxCert.hs index d5e4050d..b71ca4cb 100644 --- a/src/GeniusYield/Types/TxCert.hs +++ b/src/GeniusYield/Types/TxCert.hs @@ -1,31 +1,29 @@ -{-| +{- | Module : GeniusYield.Types.TxCert Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.TxCert ( - GYTxCert, - GYTxCertWitness (..), - txCertToApi, - mkStakeAddressRegistrationCertificate, - mkStakeAddressDeregistrationCertificate, - mkStakeAddressDelegationCertificate, + GYTxCert, + GYTxCertWitness (..), + txCertToApi, + mkStakeAddressRegistrationCertificate, + mkStakeAddressDeregistrationCertificate, + mkStakeAddressDelegationCertificate, ) where -import GeniusYield.Types.Certificate -import GeniusYield.Types.Credential (GYStakeCredential (..)) -import GeniusYield.Types.Delegatee (GYDelegatee) -import GeniusYield.Types.TxCert.Internal +import GeniusYield.Types.Certificate +import GeniusYield.Types.Credential (GYStakeCredential (..)) +import GeniusYield.Types.Delegatee (GYDelegatee) +import GeniusYield.Types.TxCert.Internal -{-| Post conway, newer stake address registration certificate also require a witness. --} +-- | Post conway, newer stake address registration certificate also require a witness. mkStakeAddressRegistrationCertificate :: GYStakeCredential -> GYTxCertWitness v -> GYTxCert v mkStakeAddressRegistrationCertificate sc wit = GYTxCert (GYStakeAddressRegistrationCertificatePB sc) (Just wit) -{-| Note that deregistration certificate requires following preconditions: +{- | Note that deregistration certificate requires following preconditions: 1. The stake address must be registered. diff --git a/src/GeniusYield/Types/TxCert/Internal.hs b/src/GeniusYield/Types/TxCert/Internal.hs index e7ea525e..3e8b0205 100644 --- a/src/GeniusYield/Types/TxCert/Internal.hs +++ b/src/GeniusYield/Types/TxCert/Internal.hs @@ -1,70 +1,68 @@ -{-| +{- | Module : GeniusYield.Types.TxCert.Internal Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.TxCert.Internal ( - GYTxCert (..), - GYTxCert' (..), - finaliseTxCert, - GYTxCertWitness (..), - txCertToApi, + GYTxCert (..), + GYTxCert' (..), + finaliseTxCert, + GYTxCertWitness (..), + txCertToApi, ) where +import Cardano.Api qualified as Api +import Data.Functor ((<&>)) +import GeniusYield.Imports ((&)) +import GeniusYield.Types.Certificate +import GeniusYield.Types.Credential (stakeCredentialToApi) +import GeniusYield.Types.Era +import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) +import GeniusYield.Types.Redeemer +import GeniusYield.Types.Script + +{- | A transaction certificate. + +The parameter @v@ indicates the minimum version of scripts allowed to witness certificates +in the transaction. -import qualified Cardano.Api as Api -import Data.Functor ((<&>)) -import GeniusYield.Imports ((&)) -import GeniusYield.Types.Certificate -import GeniusYield.Types.Credential (stakeCredentialToApi) -import GeniusYield.Types.Era -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) -import GeniusYield.Types.Redeemer -import GeniusYield.Types.Script --- | A transaction certificate. --- --- The parameter @v@ indicates the minimum version of scripts allowed to witness certificates --- in the transaction. --- --- Note that witness is not required for registering a stake address and for moving instantaneous rewards. Thus, we provide helper utilities to interact with `GYTxCert` sanely and thus keep it's representation opaque. --- +Note that witness is not required for registering a stake address and for moving instantaneous rewards. Thus, we provide helper utilities to interact with `GYTxCert` sanely and thus keep it's representation opaque. +-} data GYTxCert v = GYTxCert - { gyTxCertCertificate :: !GYCertificatePreBuild - , gyTxCertWitness :: !(Maybe (GYTxCertWitness v)) - } + { gyTxCertCertificate :: !GYCertificatePreBuild + , gyTxCertWitness :: !(Maybe (GYTxCertWitness v)) + } deriving (Eq, Show) data GYTxCert' v = GYTxCert' - { gyTxCertCertificate' :: !GYCertificate - , gyTxCertWitness' :: !(Maybe (GYTxCertWitness v)) - } + { gyTxCertCertificate' :: !GYCertificate + , gyTxCertWitness' :: !(Maybe (GYTxCertWitness v)) + } deriving (Eq, Show) finaliseTxCert :: ApiProtocolParameters -> GYTxCert v -> GYTxCert' v finaliseTxCert pp (GYTxCert cert wit) = GYTxCert' (finaliseCert pp cert) wit - -- | Represents witness type and associated information for a certificate. data GYTxCertWitness v - -- | Key witness. - = GYTxCertWitnessKey - -- | Script witness with associated script and redeemer. - | GYTxCertWitnessScript !(GYStakeValScript v) !GYRedeemer - deriving stock (Eq, Show) + = -- | Key witness. + GYTxCertWitnessKey + | -- | Script witness with associated script and redeemer. + GYTxCertWitnessScript !(GYStakeValScript v) !GYRedeemer + deriving stock (Eq, Show) -txCertToApi - :: GYTxCert' v - -> (Api.Certificate ApiEra, Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake ApiEra)) -txCertToApi (GYTxCert' cert wit) = (certificateToApi cert, wit <&> (\wit' -> (certificateToStakeCredential cert & stakeCredentialToApi, f wit')) ) +txCertToApi :: + GYTxCert' v -> + (Api.Certificate ApiEra, Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake ApiEra)) +txCertToApi (GYTxCert' cert wit) = (certificateToApi cert, wit <&> (\wit' -> (certificateToStakeCredential cert & stakeCredentialToApi, f wit'))) where f :: GYTxCertWitness v -> Api.Witness Api.WitCtxStake ApiEra f GYTxCertWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr f (GYTxCertWitnessScript v r) = - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - gyStakeValScriptWitnessToApiPlutusSW - v - (redeemerToApi r) - (Api.ExecutionUnits 0 0) + Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ + gyStakeValScriptWitnessToApiPlutusSW + v + (redeemerToApi r) + (Api.ExecutionUnits 0 0) diff --git a/src/GeniusYield/Types/TxIn.hs b/src/GeniusYield/Types/TxIn.hs index fd0030ab..bfd7b018 100644 --- a/src/GeniusYield/Types/TxIn.hs +++ b/src/GeniusYield/Types/TxIn.hs @@ -1,108 +1,112 @@ -{-| +{- | Module : GeniusYield.Types.TxIn Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.TxIn ( - GYTxIn (..), - GYInScript (..), - GYInSimpleScript (..), - inScriptVersion, - GYTxInWitness (..), - txInToApi, + GYTxIn (..), + GYInScript (..), + GYInSimpleScript (..), + inScriptVersion, + GYTxInWitness (..), + txInToApi, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api -import Data.GADT.Compare (defaultEq) -import GeniusYield.Types.Datum -import GeniusYield.Types.Era -import GeniusYield.Types.PlutusVersion -import GeniusYield.Types.Redeemer -import GeniusYield.Types.Script -import GeniusYield.Types.TxOutRef --- | Transaction input: --- --- * an UTxO --- --- * non-key witness for script utxos --- --- The parameter @v@ indicates the minimum version of scripts allowed as inputs --- in the transaction. --- +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api +import Data.GADT.Compare (defaultEq) +import GeniusYield.Types.Datum +import GeniusYield.Types.Era +import GeniusYield.Types.PlutusVersion +import GeniusYield.Types.Redeemer +import GeniusYield.Types.Script +import GeniusYield.Types.TxOutRef + +{- | Transaction input: + +* an UTxO + +* non-key witness for script utxos + +The parameter @v@ indicates the minimum version of scripts allowed as inputs +in the transaction. +-} data GYTxIn v = GYTxIn - { gyTxInTxOutRef :: !GYTxOutRef - , gyTxInWitness :: !(GYTxInWitness v) - } + { gyTxInTxOutRef :: !GYTxOutRef + , gyTxInWitness :: !(GYTxInWitness v) + } deriving (Eq, Show) -- | Represents witness type and associated information for tx inputs. data GYTxInWitness v - -- | Key witness without datum. - = GYTxInWitnessKey - -- | Script witness with associated script, datum, and redeemer. - | GYTxInWitnessScript !(GYInScript v) !GYDatum !GYRedeemer - -- | Simple script witness. - | GYTxInWitnessSimpleScript !(GYInSimpleScript v) - deriving stock (Eq, Show) + = -- | Key witness without datum. + GYTxInWitnessKey + | -- | Script witness with associated script, datum, and redeemer. + GYTxInWitnessScript !(GYInScript v) !GYDatum !GYRedeemer + | -- | Simple script witness. + GYTxInWitnessSimpleScript !(GYInSimpleScript v) + deriving stock (Eq, Show) data GYInScript (u :: PlutusVersion) where - -- | 'VersionIsGreaterOrEqual' restricts which version validators can be used in this transaction. - GYInScript :: forall u v. v `VersionIsGreaterOrEqual` u => GYValidator v -> GYInScript u - - -- | Reference inputs can be only used in V2 transactions. - GYInReference :: forall v. (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYInScript v + -- | 'VersionIsGreaterOrEqual' restricts which version validators can be used in this transaction. + GYInScript :: forall u v. (v `VersionIsGreaterOrEqual` u) => GYValidator v -> GYInScript u + -- | Reference inputs can be only used in V2 transactions. + GYInReference :: forall v. (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYInScript v -- | Returns the 'PlutusVersion' of the given 'GYInScript'. inScriptVersion :: GYInScript v -> PlutusVersion inScriptVersion (GYInReference _ s) = case scriptVersion s of - SingPlutusV3 -> PlutusV3 - SingPlutusV2 -> PlutusV2 -inScriptVersion (GYInScript v) = case validatorVersion v of - SingPlutusV3 -> PlutusV3 - SingPlutusV2 -> PlutusV2 - SingPlutusV1 -> PlutusV1 + SingPlutusV3 -> PlutusV3 + SingPlutusV2 -> PlutusV2 +inScriptVersion (GYInScript v) = case validatorVersion v of + SingPlutusV3 -> PlutusV3 + SingPlutusV2 -> PlutusV2 + SingPlutusV1 -> PlutusV1 deriving instance Show (GYInScript v) instance Eq (GYInScript v) where - GYInReference ref1 script1 == GYInReference ref2 script2 = ref1 == ref2 && script1 == script2 - GYInScript v1 == GYInScript v2 = defaultEq v1 v2 - _ == _ = False + GYInReference ref1 script1 == GYInReference ref2 script2 = ref1 == ref2 && script1 == script2 + GYInScript v1 == GYInScript v2 = defaultEq v1 v2 + _ == _ = False data GYInSimpleScript (u :: PlutusVersion) where - GYInSimpleScript :: !GYSimpleScript -> GYInSimpleScript u - GYInReferenceSimpleScript :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !GYSimpleScript -> GYInSimpleScript v + GYInSimpleScript :: !GYSimpleScript -> GYInSimpleScript u + GYInReferenceSimpleScript :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !GYSimpleScript -> GYInSimpleScript v deriving instance Show (GYInSimpleScript v) instance Eq (GYInSimpleScript v) where - GYInSimpleScript s1 == GYInSimpleScript s2 = s1 == s2 - GYInReferenceSimpleScript ref1 s1 == GYInReferenceSimpleScript ref2 s2 = ref1 == ref2 && s1 == s2 - _ == _ = False - --- | --- --- /Note:/ @TxIns@ type synonym is not exported: https://github.com/input-output-hk/cardano-node/issues/3732 -txInToApi - :: Bool -- ^ does corresponding utxo contains inline datum? - -> GYTxIn v - -> (Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn ApiEra)) -txInToApi useInline (GYTxIn oref m) = (txOutRefToApi oref, Api.BuildTxWith $ f m) where + GYInSimpleScript s1 == GYInSimpleScript s2 = s1 == s2 + GYInReferenceSimpleScript ref1 s1 == GYInReferenceSimpleScript ref2 s2 = ref1 == ref2 && s1 == s2 + _ == _ = False + +{- | + +/Note:/ @TxIns@ type synonym is not exported: https://github.com/input-output-hk/cardano-node/issues/3732 +-} +txInToApi :: + -- | does corresponding utxo contains inline datum? + Bool -> + GYTxIn v -> + (Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn ApiEra)) +txInToApi useInline (GYTxIn oref m) = (txOutRefToApi oref, Api.BuildTxWith $ f m) + where f :: GYTxInWitness v -> Api.Witness Api.WitCtxTxIn ApiEra f GYTxInWitnessKey = Api.KeyWitness Api.KeyWitnessForSpending f (GYTxInWitnessScript v d r) = - Api.ScriptWitness Api.ScriptWitnessForSpending $ (case v of - GYInScript s -> validatorToApiPlutusScriptWitness s - GYInReference ref s -> referenceScriptToApiPlutusScriptWitness ref s) - (if useInline then Api.InlineScriptDatum else Api.ScriptDatumForTxIn $ Just $ datumToApi' d) - (redeemerToApi r) - (Api.ExecutionUnits 0 0) + Api.ScriptWitness Api.ScriptWitnessForSpending $ + ( case v of + GYInScript s -> validatorToApiPlutusScriptWitness s + GYInReference ref s -> referenceScriptToApiPlutusScriptWitness ref s + ) + (if useInline then Api.InlineScriptDatum else Api.ScriptDatumForTxIn $ Just $ datumToApi' d) + (redeemerToApi r) + (Api.ExecutionUnits 0 0) f (GYTxInWitnessSimpleScript v) = - Api.ScriptWitness Api.ScriptWitnessForSpending $ Api.SimpleScriptWitness Api.SimpleScriptInConway $ h v + Api.ScriptWitness Api.ScriptWitnessForSpending $ Api.SimpleScriptWitness Api.SimpleScriptInConway $ h v h (GYInSimpleScript v) = Api.SScript $ simpleScriptToApi v h (GYInReferenceSimpleScript ref s) = Api.SReferenceScript (txOutRefToApi ref) $ Just $ hashSimpleScript' s diff --git a/src/GeniusYield/Types/TxMetadata.hs b/src/GeniusYield/Types/TxMetadata.hs index 0248c281..54bc86d8 100644 --- a/src/GeniusYield/Types/TxMetadata.hs +++ b/src/GeniusYield/Types/TxMetadata.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.Types.TxMetadata Copyright : (c) 2024 GYELD GMBH License : Apache 2.0 @@ -23,20 +23,21 @@ module GeniusYield.Types.TxMetadata ( constructTxMetadataTextChunks, mergeTxMetadata, metadataMsg, - metadataMsgs + metadataMsgs, ) where -import qualified Cardano.Api as Api -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.Map.Strict as Map -import qualified Data.Text.Encoding as TE -import Data.Word (Word64) -import GeniusYield.Imports (Text) -import GeniusYield.Types.TxMetadata.Internal (GYTxMetadataValue (..), - txMetadataValueFromApi, - txMetadataValueToApi) - +import Cardano.Api qualified as Api +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Map.Strict qualified as Map +import Data.Text.Encoding qualified as TE +import Data.Word (Word64) +import GeniusYield.Imports (Text) +import GeniusYield.Types.TxMetadata.Internal ( + GYTxMetadataValue (..), + txMetadataValueFromApi, + txMetadataValueToApi, + ) newtype GYTxMetadata = GYTxMetadata (Map.Map Word64 GYTxMetadataValue) deriving newtype (Eq, Semigroup, Show) @@ -58,26 +59,26 @@ constructTxMetadataList = GYTxMetaList -- | Construct a 'GYTxMetadataValue' from an 'Integer'. Returning 'Nothing' if the given 'Integer' is not in the range @-(2^64-1) .. 2^64-1@. constructTxMetadataNumber :: Integer -> Maybe GYTxMetadataValue constructTxMetadataNumber n = - let bound :: Integer = fromIntegral (maxBound :: Word64) in - if n >= negate bound && n <= bound - then Just $ GYTxMetaNumber n - else Nothing + let bound :: Integer = fromIntegral (maxBound :: Word64) + in if n >= negate bound && n <= bound + then Just $ GYTxMetaNumber n + else Nothing -- | Construct a 'GYTxMetadataValue' from a 'ByteString'. Returning 'Nothing' if the given 'ByteString' is longer than 64 bytes. constructTxMetadataBytes :: ByteString -> Maybe GYTxMetadataValue constructTxMetadataBytes bs = - let len = BS.length bs in - if len <= 64 - then Just $ GYTxMetaBytes bs - else Nothing + let len = BS.length bs + in if len <= 64 + then Just $ GYTxMetaBytes bs + else Nothing -- | Construct a 'GYTxMetadataValue' from a 'Text'. Returning 'Nothing' if the given 'Text' is longer than 64 bytes when UTF-8 encoded. constructTxMetadataText :: Text -> Maybe GYTxMetadataValue constructTxMetadataText txt = - let len = BS.length $ TE.encodeUtf8 txt in - if len <= 64 - then Just $ GYTxMetaText txt - else Nothing + let len = BS.length $ TE.encodeUtf8 txt + in if len <= 64 + then Just $ GYTxMetaText txt + else Nothing -- | Construct a 'GYTxMetadataValue' from a 'ByteString' as a list of chunks (bytestrings) of acceptable sizes, splitting at 64th byte as maximum length allowed is 64 bytes. constructTxMetadataBytesChunks :: ByteString -> GYTxMetadataValue @@ -90,7 +91,7 @@ constructTxMetadataTextChunks = txMetadataValueFromApi . Api.TxMetaList . constr constructTxMetadataTextChunks' :: Text -> [Api.TxMetadataValue] constructTxMetadataTextChunks' txt = case Api.metaTextChunks txt of Api.TxMetaList xs -> xs - _ -> error "GeniusYield.Types.TxMetadata.constructTxMetadataTextChunks': Absurd, expected TxMetaList" + _ -> error "GeniusYield.Types.TxMetadata.constructTxMetadataTextChunks': Absurd, expected TxMetaList" -- | Merge two 'GYTxMetadata's, controlling how to handle the respective 'GYTxMetadataValue's in case of label collision. mergeTxMetadata :: (GYTxMetadataValue -> GYTxMetadataValue -> GYTxMetadataValue) -> GYTxMetadata -> GYTxMetadata -> GYTxMetadata @@ -100,30 +101,31 @@ mergeTxMetadata f (GYTxMetadata m1) (GYTxMetadata m2) = GYTxMetadata $ Map.union -- Convenience functions for adding messages (comments/memos) following CIP 020 specification. ---------------------------------------------------------------------------------------------- --- | Adds a single message (comment/memo) as transaction metadata following CIP 020 specification. --- --- See 'metadataMsgs' for examples. +{- | Adds a single message (comment/memo) as transaction metadata following CIP 020 specification. + +See 'metadataMsgs' for examples. +-} metadataMsg :: Text -> Maybe GYTxMetadata metadataMsg msg = metadataMsgs [msg] --- | Adds multiple messages (comments/memos) as transaction metadata following CIP 020 specification. --- --- >>> metadataMsgs ["Hello, World!", "This is a test message."] --- Just (fromList [(674,GYTxMetaMap [(GYTxMetaText "msg",GYTxMetaList [GYTxMetaText "Hello, World!",GYTxMetaText "This is a test message."])])]) --- --- >>> metadataMsgs [""] --- Nothing --- --- >>> metadataMsgs [] --- Nothing --- --- >>> metadataMsgs ["Hello, World!", "This one is a reaaaaaaaally long message, so long that it exceeds the 64 byte limit, so it will be split into multiple chunks.", "do you see that?"] --- Just (fromList [(674,GYTxMetaMap [(GYTxMetaText "msg",GYTxMetaList [GYTxMetaText "Hello, World!",GYTxMetaText "This one is a reaaaaaaaally long message, so long that it exceed",GYTxMetaText "s the 64 byte limit, so it will be split into multiple chunks.",GYTxMetaText "do you see that?"])])]) --- +{- | Adds multiple messages (comments/memos) as transaction metadata following CIP 020 specification. + +>>> metadataMsgs ["Hello, World!", "This is a test message."] +Just (fromList [(674,GYTxMetaMap [(GYTxMetaText "msg",GYTxMetaList [GYTxMetaText "Hello, World!",GYTxMetaText "This is a test message."])])]) + +>>> metadataMsgs [""] +Nothing + +>>> metadataMsgs [] +Nothing + +>>> metadataMsgs ["Hello, World!", "This one is a reaaaaaaaally long message, so long that it exceeds the 64 byte limit, so it will be split into multiple chunks.", "do you see that?"] +Just (fromList [(674,GYTxMetaMap [(GYTxMetaText "msg",GYTxMetaList [GYTxMetaText "Hello, World!",GYTxMetaText "This one is a reaaaaaaaally long message, so long that it exceed",GYTxMetaText "s the 64 byte limit, so it will be split into multiple chunks.",GYTxMetaText "do you see that?"])])]) +-} metadataMsgs :: [Text] -> Maybe GYTxMetadata metadataMsgs msgs = case metaValue of GYTxMetaList [] -> Nothing - _ -> Just $ GYTxMetadata $ Map.fromList [(674, GYTxMetaMap [(GYTxMetaText "msg", metaValue)])] + _ -> Just $ GYTxMetadata $ Map.fromList [(674, GYTxMetaMap [(GYTxMetaText "msg", metaValue)])] where metaValue :: GYTxMetadataValue metaValue = txMetadataValueFromApi $ Api.TxMetaList $ concatMap constructTxMetadataTextChunks' msgs diff --git a/src/GeniusYield/Types/TxMetadata/Internal.hs b/src/GeniusYield/Types/TxMetadata/Internal.hs index 7d168be4..93cd742c 100644 --- a/src/GeniusYield/Types/TxMetadata/Internal.hs +++ b/src/GeniusYield/Types/TxMetadata/Internal.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : GeniusYield.Types.TxMetadata.Internal Copyright : (c) 2024 GYELD GMBH License : Apache 2.0 @@ -7,20 +7,19 @@ Stability : develop Internal module defining the 'GYTxMetadataValue' type and exposing all it's constructors. -} - module GeniusYield.Types.TxMetadata.Internal ( GYTxMetadataValue (..), txMetadataValueToApi, - txMetadataValueFromApi + txMetadataValueFromApi, ) where -import qualified Cardano.Api as Api -import Data.ByteString (ByteString) -import GeniusYield.Imports (Text, bimap) +import Cardano.Api qualified as Api +import Data.ByteString (ByteString) +import GeniusYield.Imports (Text, bimap) -- | A value in the transaction metadata. -data GYTxMetadataValue = - GYTxMetaMap [(GYTxMetadataValue, GYTxMetadataValue)] +data GYTxMetadataValue + = GYTxMetaMap [(GYTxMetadataValue, GYTxMetadataValue)] | GYTxMetaList [GYTxMetadataValue] | GYTxMetaNumber Integer | GYTxMetaBytes ByteString diff --git a/src/GeniusYield/Types/TxOut.hs b/src/GeniusYield/Types/TxOut.hs index e98700cc..9548fe41 100644 --- a/src/GeniusYield/Types/TxOut.hs +++ b/src/GeniusYield/Types/TxOut.hs @@ -1,95 +1,98 @@ -{-| +{- | Module : GeniusYield.Types.TxOut Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.TxOut ( - GYTxOut (..), - GYTxOutUseInlineDatum (..), - gyTxOutDatumL, - mkGYTxOut, - mkGYTxOutNoDatum, - txOutToApi, + GYTxOut (..), + GYTxOutUseInlineDatum (..), + gyTxOutDatumL, + mkGYTxOut, + mkGYTxOutNoDatum, + txOutToApi, ) where -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import Control.Lens (Traversal) -import GeniusYield.Types.Address -import GeniusYield.Types.Datum -import GeniusYield.Types.Era -import GeniusYield.Types.PlutusVersion -import GeniusYield.Types.Script -import GeniusYield.Types.Value +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Control.Lens (Traversal) +import GeniusYield.Types.Address +import GeniusYield.Types.Datum +import GeniusYield.Types.Era +import GeniusYield.Types.PlutusVersion +import GeniusYield.Types.Script +import GeniusYield.Types.Value + +{- | Transaction output. --- | Transaction output. --- --- The parameter @v@ indicates the minimum version of scripts allowed as inputs --- in the transaction. --- +The parameter @v@ indicates the minimum version of scripts allowed as inputs +in the transaction. +-} data GYTxOut (v :: PlutusVersion) = GYTxOut - { gyTxOutAddress :: !GYAddress - , gyTxOutValue :: !GYValue - , gyTxOutDatum :: !(Maybe (GYDatum, GYTxOutUseInlineDatum v)) -- ^ The Boolean indicates whether to use inline datums or not. May be overridden by a flag to 'txOutToApi'. - , gyTxOutRefS :: !(Maybe GYAnyScript) - } deriving stock (Eq, Show) + { gyTxOutAddress :: !GYAddress + , gyTxOutValue :: !GYValue + , gyTxOutDatum :: !(Maybe (GYDatum, GYTxOutUseInlineDatum v)) + -- ^ The Boolean indicates whether to use inline datums or not. May be overridden by a flag to 'txOutToApi'. + , gyTxOutRefS :: !(Maybe GYAnyScript) + } + deriving stock (Eq, Show) data GYTxOutUseInlineDatum (v :: PlutusVersion) where - GYTxOutUseInlineDatum :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => GYTxOutUseInlineDatum v - GYTxOutDontUseInlineDatum :: GYTxOutUseInlineDatum v + GYTxOutUseInlineDatum :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => GYTxOutUseInlineDatum v + GYTxOutDontUseInlineDatum :: GYTxOutUseInlineDatum v deriving instance Show (GYTxOutUseInlineDatum v) deriving instance Eq (GYTxOutUseInlineDatum v) -- | The most common variant: create a 'GYTxOut' from address, value and datum mkGYTxOut :: GYAddress -> GYValue -> GYDatum -> GYTxOut v -mkGYTxOut addr v d = GYTxOut - { gyTxOutAddress = addr - , gyTxOutValue = v - , gyTxOutDatum = Just (d, GYTxOutDontUseInlineDatum) - , gyTxOutRefS = Nothing +mkGYTxOut addr v d = + GYTxOut + { gyTxOutAddress = addr + , gyTxOutValue = v + , gyTxOutDatum = Just (d, GYTxOutDontUseInlineDatum) + , gyTxOutRefS = Nothing } -- | Same as 'mkGYTxOut' but without a datum. mkGYTxOutNoDatum :: GYAddress -> GYValue -> GYTxOut v -mkGYTxOutNoDatum addr v = GYTxOut - { gyTxOutAddress = addr - , gyTxOutValue = v - , gyTxOutDatum = Nothing - , gyTxOutRefS = Nothing +mkGYTxOutNoDatum addr v = + GYTxOut + { gyTxOutAddress = addr + , gyTxOutValue = v + , gyTxOutDatum = Nothing + , gyTxOutRefS = Nothing } -- | Whether to use inline datum in this transaction output gyTxOutDatumL :: Traversal (GYTxOut v) (GYTxOut u) (GYTxOutUseInlineDatum v) (GYTxOutUseInlineDatum u) gyTxOutDatumL f (GYTxOut addr v md s) = - (\md' -> GYTxOut addr v md' s) <$> traverse (traverse f) md + (\md' -> GYTxOut addr v md' s) <$> traverse (traverse f) md -txOutToApi - :: GYTxOut v - -> Api.TxOut Api.CtxTx ApiEra -txOutToApi (GYTxOut addr v md mrs) = Api.TxOut +txOutToApi :: + GYTxOut v -> + Api.TxOut Api.CtxTx ApiEra +txOutToApi (GYTxOut addr v md mrs) = + Api.TxOut (addressToApi' addr) (valueToApiTxOutValue v) (mkDatum md) (maybe Api.S.ReferenceScriptNone (Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway . resolveOutputScript) mrs) where - resolveOutputScript (GYSimpleScript s) = Api.ScriptInAnyLang Api.SimpleScriptLanguage (Api.SimpleScript $ simpleScriptToApi s) resolveOutputScript (GYPlutusScript s) = - let version = singPlutusVersionToApi $ scriptVersion s - in Api.ScriptInAnyLang (Api.PlutusScriptLanguage version) (Api.PlutusScript version (scriptToApi s)) + let version = singPlutusVersionToApi $ scriptVersion s + in Api.ScriptInAnyLang (Api.PlutusScriptLanguage version) (Api.PlutusScript version (scriptToApi s)) mkDatum :: Maybe (GYDatum, GYTxOutUseInlineDatum v) -> Api.TxOutDatum Api.CtxTx ApiEra - mkDatum Nothing = Api.TxOutDatumNone + mkDatum Nothing = Api.TxOutDatumNone mkDatum (Just (d, di)) - | di' = Api.TxOutDatumInline Api.BabbageEraOnwardsConway d' - | otherwise = Api.TxOutDatumInTx Api.AlonzoEraOnwardsConway d' + | di' = Api.TxOutDatumInline Api.BabbageEraOnwardsConway d' + | otherwise = Api.TxOutDatumInTx Api.AlonzoEraOnwardsConway d' where d' = datumToApi' d di' = case di of - GYTxOutUseInlineDatum -> True + GYTxOutUseInlineDatum -> True GYTxOutDontUseInlineDatum -> False diff --git a/src/GeniusYield/Types/TxOutRef.hs b/src/GeniusYield/Types/TxOutRef.hs index e015a077..af6615c4 100644 --- a/src/GeniusYield/Types/TxOutRef.hs +++ b/src/GeniusYield/Types/TxOutRef.hs @@ -1,61 +1,62 @@ -{-| +{- | Module : GeniusYield.Types.TxOutRef Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.TxOutRef ( - GYTxOutRef, - txOutRefToPlutus, - txOutRefFromPlutus, - txOutRefFromApi, - txOutRefFromApiTxIdIx, - wordToApiIx, - txOutRefToApi, - -- * Helpers - showTxOutRef, - txOutRefToTuple, - txOutRefToTuple', - txOutRefFromTuple, - -- * CBOR format - GYTxOutRefCbor (..), + GYTxOutRef, + txOutRefToPlutus, + txOutRefFromPlutus, + txOutRefFromApi, + txOutRefFromApiTxIdIx, + wordToApiIx, + txOutRefToApi, + + -- * Helpers + showTxOutRef, + txOutRefToTuple, + txOutRefToTuple', + txOutRefFromTuple, + + -- * CBOR format + GYTxOutRefCbor (..), ) where -import qualified Cardano.Api as Api -import qualified Codec.CBOR.Read as CBOR -import qualified Codec.CBOR.Term as CBOR -import Control.Lens ((?~)) -import qualified Data.Aeson as Aeson -import qualified Data.Attoparsec.ByteString.Char8 as Atto -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Csv as Csv -import Data.Hashable (Hashable (..)) -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Swagger.Lens () -import qualified Data.Text as T -import qualified Data.Text as Text -import qualified Data.Text.Encoding as TE -import qualified PlutusLedgerApi.V1 as Plutus (TxOutRef (..), TxId (..)) -import qualified PlutusTx.Builtins.Internal as Plutus -import qualified Text.Printf as Printf -import qualified Web.HttpApiData as Web - -import Data.Either.Combinators (mapLeft) -import GeniusYield.Imports -import GeniusYield.Types.Ledger -import GeniusYield.Types.Tx - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Data.Csv as Csv --- >>> import qualified PlutusLedgerApi.V1 as Plutus --- >>> import qualified Web.HttpApiData as Web --- +import Cardano.Api qualified as Api +import Codec.CBOR.Read qualified as CBOR +import Codec.CBOR.Term qualified as CBOR +import Control.Lens ((?~)) +import Data.Aeson qualified as Aeson +import Data.Attoparsec.ByteString.Char8 qualified as Atto +import Data.ByteString.Base16 qualified as Base16 +import Data.ByteString.Lazy qualified as LBS +import Data.Csv qualified as Csv +import Data.Hashable (Hashable (..)) +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Swagger.Lens qualified () +import Data.Text qualified as T +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import PlutusLedgerApi.V1 qualified as Plutus (TxId (..), TxOutRef (..)) +import PlutusTx.Builtins.Internal qualified as Plutus +import Text.Printf qualified as Printf +import Web.HttpApiData qualified as Web + +import Data.Either.Combinators (mapLeft) +import GeniusYield.Imports +import GeniusYield.Types.Ledger +import GeniusYield.Types.Tx + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Csv as Csv +>>> import qualified PlutusLedgerApi.V1 as Plutus +>>> import qualified Web.HttpApiData as Web +-} ------------------------------------------------------------------------------- -- GYTxOutRef @@ -63,48 +64,51 @@ import GeniusYield.Types.Tx -- | Type that represents a reference to a 'GYTxOut'. newtype GYTxOutRef = GYTxOutRef Api.TxIn - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord) deriving newtype (Aeson.FromJSON, Aeson.ToJSON) instance Hashable GYTxOutRef where - hashWithSalt salt (GYTxOutRef (Api.TxIn x (Api.TxIx y))) = salt - `hashWithSalt` Api.serialiseToRawBytes x - `hashWithSalt` y - --- | --- --- >>> txOutRefFromPlutus $ Plutus.TxOutRef "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" 12 --- Right (GYTxOutRef (TxIn "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" (TxIx 12))) --- --- >>> txOutRefFromPlutus $ Plutus.TxOutRef "ae" 12 --- Left (UnknownPlutusToCardanoError {ptceTag = "txOutRefFromPlutus: invalid txOutRefId ae, error: SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise TxId\"}"}) --- --- >>> txOutRefFromPlutus $ Plutus.TxOutRef "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" (-2) --- Left (UnknownPlutusToCardanoError {ptceTag = "txOutRefFromPlutus: negative txOutRefIdx -2"}) --- --- >>> txOutRefFromPlutus $ Plutus.TxOutRef "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" 123456789012345678901 --- Left (UnknownPlutusToCardanoError {ptceTag = "txOutRefFromPlutus: txOutRefIdx 123456789012345678901 too large"}) --- + hashWithSalt salt (GYTxOutRef (Api.TxIn x (Api.TxIx y))) = + salt + `hashWithSalt` Api.serialiseToRawBytes x + `hashWithSalt` y + +{- | + +>>> txOutRefFromPlutus $ Plutus.TxOutRef "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" 12 +Right (GYTxOutRef (TxIn "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" (TxIx 12))) + +>>> txOutRefFromPlutus $ Plutus.TxOutRef "ae" 12 +Left (UnknownPlutusToCardanoError {ptceTag = "txOutRefFromPlutus: invalid txOutRefId ae, error: SerialiseAsRawBytesError {unSerialiseAsRawBytesError = \"Unable to deserialise TxId\"}"}) + +>>> txOutRefFromPlutus $ Plutus.TxOutRef "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" (-2) +Left (UnknownPlutusToCardanoError {ptceTag = "txOutRefFromPlutus: negative txOutRefIdx -2"}) + +>>> txOutRefFromPlutus $ Plutus.TxOutRef "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" 123456789012345678901 +Left (UnknownPlutusToCardanoError {ptceTag = "txOutRefFromPlutus: txOutRefIdx 123456789012345678901 too large"}) +-} txOutRefFromPlutus :: Plutus.TxOutRef -> Either PlutusToCardanoError GYTxOutRef txOutRefFromPlutus (Plutus.TxOutRef tid@(Plutus.TxId (Plutus.BuiltinByteString bs)) ix) = coerce . Api.TxIn <$> etid <*> eix where etid :: Either PlutusToCardanoError Api.TxId - etid = mapLeft (\e -> UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: invalid txOutRefId " <> show tid <> ", error: " <> show e) - $ Api.deserialiseFromRawBytes Api.AsTxId bs + etid = + mapLeft (\e -> UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: invalid txOutRefId " <> show tid <> ", error: " <> show e) $ + Api.deserialiseFromRawBytes Api.AsTxId bs eix :: Either PlutusToCardanoError Api.TxIx eix - | ix < 0 = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: negative txOutRefIdx " ++ show ix - | ix > toInteger (maxBound @Word) = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: txOutRefIdx " ++ show ix ++ " too large" - | otherwise = Right $ Api.TxIx $ fromInteger ix - --- | --- --- >>> txOutRefToPlutus "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" --- TxOutRef {txOutRefId = 4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189, txOutRefIdx = 1} --- + | ix < 0 = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: negative txOutRefIdx " ++ show ix + | ix > toInteger (maxBound @Word) = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: txOutRefIdx " ++ show ix ++ " too large" + | otherwise = Right $ Api.TxIx $ fromInteger ix + +{- | + +>>> txOutRefToPlutus "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" +TxOutRef {txOutRefId = 4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189, txOutRefIdx = 1} +-} txOutRefToPlutus :: GYTxOutRef -> Plutus.TxOutRef -txOutRefToPlutus (GYTxOutRef (Api.TxIn tid (Api.TxIx ix))) = Plutus.TxOutRef +txOutRefToPlutus (GYTxOutRef (Api.TxIn tid (Api.TxIx ix))) = + Plutus.TxOutRef (Plutus.TxId $ Plutus.BuiltinByteString $ Api.serialiseToRawBytes tid) (toInteger ix) @@ -129,130 +133,145 @@ txOutRefToTuple' (GYTxOutRef (Api.TxIn x (Api.TxIx y))) = (Api.serialiseToRawByt txOutRefFromTuple :: (GYTxId, Word) -> GYTxOutRef txOutRefFromTuple (txIdToApi -> x, y) = GYTxOutRef (Api.TxIn x (Api.TxIx y)) --- | --- --- >>> Web.parseUrlPiece @GYTxOutRef "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" --- Right (GYTxOutRef (TxIn "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" (TxIx 1))) --- +{- | + +>>> Web.parseUrlPiece @GYTxOutRef "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" +Right (GYTxOutRef (TxIn "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" (TxIx 1))) +-} instance Web.FromHttpApiData GYTxOutRef where - -- copy parseTxIn from cardano-api - parseUrlPiece tr = case Atto.parseOnly parser (TE.encodeUtf8 tr) of - Left err -> Left (T.pack ("GYTxOutRef: " ++ err)) - Right x -> Right x - where - parser :: Atto.Parser GYTxOutRef - parser = do - tx <- Base16.decodeLenient <$> Atto.takeWhile1 isHexDigit - _ <- Atto.char '#' - ix <- Atto.decimal - tx' <- either (\e -> fail $ "not txid bytes: " <> show tx <> " , error: " <> show e) pure $ Api.deserialiseFromRawBytes Api.AsTxId tx - return (GYTxOutRef (Api.TxIn tx' (Api.TxIx ix))) + -- copy parseTxIn from cardano-api + parseUrlPiece tr = case Atto.parseOnly parser (TE.encodeUtf8 tr) of + Left err -> Left (T.pack ("GYTxOutRef: " ++ err)) + Right x -> Right x + where + parser :: Atto.Parser GYTxOutRef + parser = do + tx <- Base16.decodeLenient <$> Atto.takeWhile1 isHexDigit + _ <- Atto.char '#' + ix <- Atto.decimal + tx' <- either (\e -> fail $ "not txid bytes: " <> show tx <> " , error: " <> show e) pure $ Api.deserialiseFromRawBytes Api.AsTxId tx + return (GYTxOutRef (Api.TxIn tx' (Api.TxIx ix))) instance Web.ToHttpApiData GYTxOutRef where - toUrlPiece = showTxOutRef + toUrlPiece = showTxOutRef instance Printf.PrintfArg GYTxOutRef where - formatArg oref = Printf.formatArg (showTxOutRef oref) + formatArg oref = Printf.formatArg (showTxOutRef oref) -- renderTxIn in cardano-api showTxOutRef :: GYTxOutRef -> Text showTxOutRef (GYTxOutRef (Api.TxIn txId (Api.TxIx ix))) = - Api.serialiseToRawBytesHexText txId <> "#" <> T.pack (show ix) - --- | --- --- >>> "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" :: GYTxOutRef --- GYTxOutRef (TxIn "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" (TxIx 1)) --- --- >>> "not-a-tx-out-ref" :: GYTxOutRef --- *** Exception: invalid GYTxOutRef: not-a-tx-out-ref --- ... --- + Api.serialiseToRawBytesHexText txId <> "#" <> T.pack (show ix) + +{- | + +>>> "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" :: GYTxOutRef +GYTxOutRef (TxIn "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" (TxIx 1)) + +>>> "not-a-tx-out-ref" :: GYTxOutRef +*** Exception: invalid GYTxOutRef: not-a-tx-out-ref +... +-} instance IsString GYTxOutRef where - fromString s = fromRight (error $ "invalid GYTxOutRef: " <> s) $ Web.parseUrlPiece $ T.pack s + fromString s = fromRight (error $ "invalid GYTxOutRef: " <> s) $ Web.parseUrlPiece $ T.pack s --- | --- --- >>> Csv.toField ("4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" :: GYTxOutRef) --- "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" --- +{- | + +>>> Csv.toField ("4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" :: GYTxOutRef) +"4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" +-} instance Csv.ToField GYTxOutRef where - toField = encodeUtf8 . showTxOutRef - --- | --- --- >>> Csv.runParser $ Csv.parseField @GYTxOutRef "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" --- Right (GYTxOutRef (TxIn "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" (TxIx 1))) --- --- >>> Csv.runParser $ Csv.parseField @GYTxOutRef "not a tx-out ref" --- Left "GYTxOutRef: Failed reading: takeWhile1" --- + toField = encodeUtf8 . showTxOutRef + +{- | + +>>> Csv.runParser $ Csv.parseField @GYTxOutRef "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" +Right (GYTxOutRef (TxIn "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" (TxIx 1))) + +>>> Csv.runParser $ Csv.parseField @GYTxOutRef "not a tx-out ref" +Left "GYTxOutRef: Failed reading: takeWhile1" +-} instance Csv.FromField GYTxOutRef where - parseField = either (fail . T.unpack) return . Web.parseUrlPiece . decodeUtf8Lenient + parseField = either (fail . T.unpack) return . Web.parseUrlPiece . decodeUtf8Lenient ------------------------------------------------------------------------------- -- swagger schema ------------------------------------------------------------------------------- instance Swagger.ToParamSchema GYTxOutRef where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "hex" - & Swagger.pattern ?~ "[0-9a-fA-F]{64}#\"d+" + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "hex" + & Swagger.pattern + ?~ "[0-9a-fA-F]{64}#\"d+" instance Swagger.ToSchema GYTxOutRef where - declareNamedSchema _ = pure $ Swagger.named "GYTxOutRef" $ Swagger.paramSchemaToSchema (Proxy @GYTxOutRef) - & Swagger.example ?~ toJSON ("4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" :: Text) + declareNamedSchema _ = + pure $ + Swagger.named "GYTxOutRef" $ + Swagger.paramSchemaToSchema (Proxy @GYTxOutRef) + & Swagger.example + ?~ toJSON ("4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#1" :: Text) ------------------------------------------------------------------------------- -- GYTxOutRefCbor ------------------------------------------------------------------------------- -newtype GYTxOutRefCbor = GYTxOutRefCbor { getTxOutRefHex :: GYTxOutRef } +newtype GYTxOutRefCbor = GYTxOutRefCbor {getTxOutRefHex :: GYTxOutRef} --- | --- --- >>> Web.parseUrlPiece @GYTxOutRefCbor "8282582004ffecdf5f3ced5c5c788833415bcbef26e3e21290fcebcf8216327e21569e420082583900e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f6161a004c4b40" --- Right GYTxOutRef (TxIn "04ffecdf5f3ced5c5c788833415bcbef26e3e21290fcebcf8216327e21569e42" (TxIx 0)) --- --- >>> Web.parseUrlPiece @GYTxOutRefCbor "00" --- Left "Invalid TxIn CBOR structure" --- +{- | + +>>> Web.parseUrlPiece @GYTxOutRefCbor "8282582004ffecdf5f3ced5c5c788833415bcbef26e3e21290fcebcf8216327e21569e420082583900e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f6161a004c4b40" +Right GYTxOutRef (TxIn "04ffecdf5f3ced5c5c788833415bcbef26e3e21290fcebcf8216327e21569e42" (TxIx 0)) + +>>> Web.parseUrlPiece @GYTxOutRefCbor "00" +Left "Invalid TxIn CBOR structure" +-} instance Web.FromHttpApiData GYTxOutRefCbor where parseUrlPiece t = do - bs <- first T.pack $ Base16.decode $ TE.encodeUtf8 t - (rest, cbor) <- first (T.pack . show) $ CBOR.deserialiseFromBytes CBOR.decodeTerm $ LBS.fromStrict bs - unless (LBS.null rest) $ Left "Left overs in input" - case cbor of - CBOR.TList [CBOR.TList [CBOR.TBytes tx, CBOR.TInt ix], _] -> do - tx' <- mapLeft (\e -> T.pack $ "not txid bytes: " ++ show tx <> ", error: " <> show e) $ Api.deserialiseFromRawBytes Api.AsTxId tx - unless (ix >= 0) $ Left "negative ix" - return (GYTxOutRefCbor (GYTxOutRef (Api.TxIn tx' (Api.TxIx (fromIntegral ix))))) - _ -> Left "Invalid TxIn CBOR structure" + bs <- first T.pack $ Base16.decode $ TE.encodeUtf8 t + (rest, cbor) <- first (T.pack . show) $ CBOR.deserialiseFromBytes CBOR.decodeTerm $ LBS.fromStrict bs + unless (LBS.null rest) $ Left "Left overs in input" + case cbor of + CBOR.TList [CBOR.TList [CBOR.TBytes tx, CBOR.TInt ix], _] -> do + tx' <- mapLeft (\e -> T.pack $ "not txid bytes: " ++ show tx <> ", error: " <> show e) $ Api.deserialiseFromRawBytes Api.AsTxId tx + unless (ix >= 0) $ Left "negative ix" + return (GYTxOutRefCbor (GYTxOutRef (Api.TxIn tx' (Api.TxIx (fromIntegral ix))))) + _ -> Left "Invalid TxIn CBOR structure" instance Show GYTxOutRefCbor where show (GYTxOutRefCbor tx) = show tx instance Printf.PrintfArg GYTxOutRefCbor where - formatArg (GYTxOutRefCbor (GYTxOutRef txRef)) = Printf.formatArg (show txRef) + formatArg (GYTxOutRefCbor (GYTxOutRef txRef)) = Printf.formatArg (show txRef) instance Aeson.FromJSON GYTxOutRefCbor where - parseJSON v = do - t <- Aeson.parseJSON v - case Web.parseUrlPiece t of - Left err -> fail $ T.unpack err - Right ref -> return ref + parseJSON v = do + t <- Aeson.parseJSON v + case Web.parseUrlPiece t of + Left err -> fail $ T.unpack err + Right ref -> return ref ------------------------------------------------------------------------------- -- swagger schema ------------------------------------------------------------------------------- instance Swagger.ToParamSchema GYTxOutRefCbor where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.format ?~ "cbor hex" - & Swagger.pattern ?~ "[0-9a-fA-F]+" + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.format + ?~ "cbor hex" + & Swagger.pattern + ?~ "[0-9a-fA-F]+" instance Swagger.ToSchema GYTxOutRefCbor where - declareNamedSchema p = Swagger.plain $ Swagger.paramSchemaToSchema p - & Swagger.example ?~ toJSON ("8282582004ffecdf5f3ced5c5c788833415bcbef26e3e21290fcebcf8216327e21569e420082583900e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f6161a004c4b40" :: Text) + declareNamedSchema p = + Swagger.plain $ + Swagger.paramSchemaToSchema p + & Swagger.example + ?~ toJSON ("8282582004ffecdf5f3ced5c5c788833415bcbef26e3e21290fcebcf8216327e21569e420082583900e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d1b930e9f7add78a174a21000e989ff551366dcd127028cb2aa39f6161a004c4b40" :: Text) diff --git a/src/GeniusYield/Types/TxWdrl.hs b/src/GeniusYield/Types/TxWdrl.hs index baf04265..59db48ab 100644 --- a/src/GeniusYield/Types/TxWdrl.hs +++ b/src/GeniusYield/Types/TxWdrl.hs @@ -1,54 +1,54 @@ -{-| +{- | Module : GeniusYield.Types.TxWdrl Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.TxWdrl ( - GYTxWdrl (..), - GYTxWdrlWitness (..), - txWdrlToApi, + GYTxWdrl (..), + GYTxWdrlWitness (..), + txWdrlToApi, ) where +import Cardano.Api qualified as Api +import Cardano.Ledger.Coin qualified as Ledger +import GeniusYield.Imports (Natural) +import GeniusYield.Types.Address (GYStakeAddress, stakeAddressToApi) +import GeniusYield.Types.Era +import GeniusYield.Types.Redeemer +import GeniusYield.Types.Script + +{- | Transaction withdrawal. -import qualified Cardano.Api as Api -import qualified Cardano.Ledger.Coin as Ledger -import GeniusYield.Imports (Natural) -import GeniusYield.Types.Address (GYStakeAddress, stakeAddressToApi) -import GeniusYield.Types.Era -import GeniusYield.Types.Redeemer -import GeniusYield.Types.Script --- | Transaction withdrawal. --- --- The parameter @v@ indicates the minimum version of scripts allowed as withdrawals --- in the transaction. --- +The parameter @v@ indicates the minimum version of scripts allowed as withdrawals +in the transaction. +-} data GYTxWdrl v = GYTxWdrl - { gyTxWdrlStakeAddress :: !GYStakeAddress - , gyTxWdrlAmount :: !Natural - , gyTxWdrlWitness :: !(GYTxWdrlWitness v) - } + { gyTxWdrlStakeAddress :: !GYStakeAddress + , gyTxWdrlAmount :: !Natural + , gyTxWdrlWitness :: !(GYTxWdrlWitness v) + } deriving (Eq, Show) -- | Represents witness type and associated information for tx withdrawals. data GYTxWdrlWitness v - -- | Key witness. - = GYTxWdrlWitnessKey - -- | Script witness with associated script and redeemer. - | GYTxWdrlWitnessScript !(GYStakeValScript v) !GYRedeemer - deriving stock (Eq, Show) + = -- | Key witness. + GYTxWdrlWitnessKey + | -- | Script witness with associated script and redeemer. + GYTxWdrlWitnessScript !(GYStakeValScript v) !GYRedeemer + deriving stock (Eq, Show) -txWdrlToApi - :: GYTxWdrl v - -> (Api.StakeAddress, Ledger.Coin, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxStake ApiEra)) -txWdrlToApi (GYTxWdrl stakeAddr amt wit) = (stakeAddressToApi stakeAddr, Ledger.Coin (toInteger amt), Api.BuildTxWith $ f wit) where +txWdrlToApi :: + GYTxWdrl v -> + (Api.StakeAddress, Ledger.Coin, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxStake ApiEra)) +txWdrlToApi (GYTxWdrl stakeAddr amt wit) = (stakeAddressToApi stakeAddr, Ledger.Coin (toInteger amt), Api.BuildTxWith $ f wit) + where f :: GYTxWdrlWitness v -> Api.Witness Api.WitCtxStake ApiEra f GYTxWdrlWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr f (GYTxWdrlWitnessScript v r) = - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - gyStakeValScriptWitnessToApiPlutusSW - v - (redeemerToApi r) - (Api.ExecutionUnits 0 0) + Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ + gyStakeValScriptWitnessToApiPlutusSW + v + (redeemerToApi r) + (Api.ExecutionUnits 0 0) diff --git a/src/GeniusYield/Types/UTxO.hs b/src/GeniusYield/Types/UTxO.hs index a35c69f4..137a387b 100644 --- a/src/GeniusYield/Types/UTxO.hs +++ b/src/GeniusYield/Types/UTxO.hs @@ -1,117 +1,122 @@ -{-| +{- | Module : GeniusYield.Types.UTxO Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.UTxO ( - GYUTxO (..), - utxoFromApi, - utxoFromApi', - utxoToPlutus, - utxoHasInlineDatum, - utxoHasReferenceScript, - utxoTranslatableToV1, - GYUTxOs, - utxosSize, - utxosFromApi, - utxosToApi, - utxosRemoveTxOutRef, - utxosRemoveTxOutRefs, - utxosRemoveRefScripts, - utxosRemoveUTxO, - utxosRemoveUTxOs, - utxosLookup, - someTxOutRef, - randomTxOutRef, - -- * UTxO datums - GYOutDatum (..), - isInlineDatum, - outDatumToPlutus, - -- * Filter and map - filterUTxOs, - mapMaybeUTxOs, - mapUTxOs, - witherUTxOs, - -- * List conversions - utxosFromList, - utxosFromUTxO, - utxosToList, - -- * Folds - foldlUTxOs', - foldMapUTxOs, - forUTxOs_, - foldMUTxOs, - -- * Extract refs - utxosRefs, + GYUTxO (..), + utxoFromApi, + utxoFromApi', + utxoToPlutus, + utxoHasInlineDatum, + utxoHasReferenceScript, + utxoTranslatableToV1, + GYUTxOs, + utxosSize, + utxosFromApi, + utxosToApi, + utxosRemoveTxOutRef, + utxosRemoveTxOutRefs, + utxosRemoveRefScripts, + utxosRemoveUTxO, + utxosRemoveUTxOs, + utxosLookup, + someTxOutRef, + randomTxOutRef, + + -- * UTxO datums + GYOutDatum (..), + isInlineDatum, + outDatumToPlutus, + + -- * Filter and map + filterUTxOs, + mapMaybeUTxOs, + mapUTxOs, + witherUTxOs, + + -- * List conversions + utxosFromList, + utxosFromUTxO, + utxosToList, + + -- * Folds + foldlUTxOs', + foldMapUTxOs, + forUTxOs_, + foldMUTxOs, + + -- * Extract refs + utxosRefs, ) where -import GeniusYield.Imports +import GeniusYield.Imports -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import Control.Monad.Random (MonadRandom (getRandomR)) -import qualified Data.Map.Strict as Map -import qualified PlutusLedgerApi.V2.Tx as Plutus -import qualified Text.Printf as Printf +import Cardano.Api qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Control.Monad.Random (MonadRandom (getRandomR)) +import Data.Map.Strict qualified as Map +import PlutusLedgerApi.V2.Tx qualified as Plutus +import Text.Printf qualified as Printf -import Data.Maybe (isNothing) -import GeniusYield.Types.Address -import GeniusYield.Types.Datum -import GeniusYield.Types.Era -import GeniusYield.Types.Script -import GeniusYield.Types.TxOutRef -import GeniusYield.Types.Value +import Data.Maybe (isNothing) +import GeniusYield.Types.Address +import GeniusYield.Types.Datum +import GeniusYield.Types.Era +import GeniusYield.Types.Script +import GeniusYield.Types.TxOutRef +import GeniusYield.Types.Value -- | The datum contained within a transaction output. data GYOutDatum - -- | The output has no datum. - = GYOutDatumNone - -- | The output contains a datum hash, the associated datum may or may not be included in the tx. - | GYOutDatumHash !GYDatumHash - -- | The output contains an inline datum (i.e datum within the output itself). - | GYOutDatumInline !GYDatum + = -- | The output has no datum. + GYOutDatumNone + | -- | The output contains a datum hash, the associated datum may or may not be included in the tx. + GYOutDatumHash !GYDatumHash + | -- | The output contains an inline datum (i.e datum within the output itself). + GYOutDatumInline !GYDatum deriving stock (Eq, Show) isInlineDatum :: GYOutDatum -> Bool isInlineDatum (GYOutDatumInline _) = True -isInlineDatum _ = False +isInlineDatum _ = False outDatumToPlutus :: GYOutDatum -> Plutus.OutputDatum -outDatumToPlutus GYOutDatumNone = Plutus.NoOutputDatum -outDatumToPlutus (GYOutDatumHash h) = Plutus.OutputDatumHash $ datumHashToPlutus h -outDatumToPlutus (GYOutDatumInline d) = Plutus.OutputDatum $ datumToPlutus d +outDatumToPlutus GYOutDatumNone = Plutus.NoOutputDatum +outDatumToPlutus (GYOutDatumHash h) = Plutus.OutputDatumHash $ datumHashToPlutus h +outDatumToPlutus (GYOutDatumInline d) = Plutus.OutputDatum $ datumToPlutus d -- | An unspent transaction output. --- data GYUTxO = GYUTxO - { utxoRef :: !GYTxOutRef - , utxoAddress :: !GYAddress - , utxoValue :: !GYValue - , utxoOutDatum :: !GYOutDatum - , utxoRefScript :: !(Maybe GYAnyScript) - } deriving stock (Eq, Show) + { utxoRef :: !GYTxOutRef + , utxoAddress :: !GYAddress + , utxoValue :: !GYValue + , utxoOutDatum :: !GYOutDatum + , utxoRefScript :: !(Maybe GYAnyScript) + } + deriving stock (Eq, Show) instance Ord GYUTxO where u1 `compare` u2 = utxoRef u1 `compare` utxoRef u2 --- | A set of unspent transaction outputs. --- --- Actually a map from unspent transaction outputs to address, value and datum hash. --- +{- | A set of unspent transaction outputs. + +Actually a map from unspent transaction outputs to address, value and datum hash. +-} newtype GYUTxOs = GYUTxOs (Map GYTxOutRef (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript)) deriving (Eq, Show) instance Semigroup GYUTxOs where - GYUTxOs x <> GYUTxOs y = GYUTxOs (Map.union x y) + GYUTxOs x <> GYUTxOs y = GYUTxOs (Map.union x y) instance Monoid GYUTxOs where - mempty = GYUTxOs mempty + mempty = GYUTxOs mempty utxosFromApi :: Api.UTxO era -> GYUTxOs -utxosFromApi (Api.UTxO m) = utxosFromList +utxosFromApi (Api.UTxO m) = + utxosFromList [ utxoFromApi' txIn out | (txIn, out) <- Map.toList m ] @@ -119,64 +124,70 @@ utxosFromApi (Api.UTxO m) = utxosFromList utxosToApi :: GYUTxOs -> Api.UTxO ApiEra utxosToApi (GYUTxOs m) = Api.UTxO $ Map.foldlWithKey' f Map.empty m where - f :: Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) - -> GYTxOutRef -> (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) - -> Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) + f :: + Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) -> + GYTxOutRef -> + (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> + Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) f m' oref out = Map.insert (txOutRefToApi oref) (g out) m' g :: (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> Api.TxOut Api.CtxUTxO ApiEra - g (addr, v, md, ms) = Api.TxOut + g (addr, v, md, ms) = + Api.TxOut (addressToApi' addr) (valueToApiTxOutValue v) (outDatumToApi md) (maybe Api.S.ReferenceScriptNone someScriptToReferenceApi ms) - outDatumToApi GYOutDatumNone = Api.TxOutDatumNone + outDatumToApi GYOutDatumNone = Api.TxOutDatumNone outDatumToApi (GYOutDatumHash h) = Api.TxOutDatumHash Api.AlonzoEraOnwardsConway $ datumHashToApi h outDatumToApi (GYOutDatumInline d) = Api.TxOutDatumInline Api.BabbageEraOnwardsConway $ datumToApi' d utxoFromApi :: Api.TxIn -> Api.TxOut Api.CtxTx ApiEra -> GYUTxO -utxoFromApi txIn (Api.TxOut a v d s) = GYUTxO - { utxoRef = txOutRefFromApi txIn - , utxoAddress = addressFromApi' a - , utxoValue = valueFromApiTxOutValue v - , utxoOutDatum = f d +utxoFromApi txIn (Api.TxOut a v d s) = + GYUTxO + { utxoRef = txOutRefFromApi txIn + , utxoAddress = addressFromApi' a + , utxoValue = valueFromApiTxOutValue v + , utxoOutDatum = f d , utxoRefScript = someScriptFromReferenceApi s } where f :: Api.TxOutDatum Api.CtxTx ApiEra -> GYOutDatum - f Api.TxOutDatumNone = GYOutDatumNone + f Api.TxOutDatumNone = GYOutDatumNone f (Api.TxOutDatumHash _ hash) = GYOutDatumHash $ datumHashFromApi hash - f (Api.TxOutDatumInTx _ sd) = GYOutDatumHash . hashDatum $ datumFromApi' sd + f (Api.TxOutDatumInTx _ sd) = GYOutDatumHash . hashDatum $ datumFromApi' sd f (Api.TxOutDatumInline _ sd) = GYOutDatumInline $ datumFromApi' sd utxoFromApi' :: Api.TxIn -> Api.TxOut Api.CtxUTxO era -> GYUTxO -utxoFromApi' txIn (Api.TxOut a v d s) = GYUTxO - { utxoRef = txOutRefFromApi txIn - , utxoAddress = addressFromApi' a - , utxoValue = valueFromApiTxOutValue v - , utxoOutDatum = f d +utxoFromApi' txIn (Api.TxOut a v d s) = + GYUTxO + { utxoRef = txOutRefFromApi txIn + , utxoAddress = addressFromApi' a + , utxoValue = valueFromApiTxOutValue v + , utxoOutDatum = f d , utxoRefScript = someScriptFromReferenceApi s } where f :: Api.TxOutDatum Api.CtxUTxO era -> GYOutDatum - f Api.TxOutDatumNone = GYOutDatumNone + f Api.TxOutDatumNone = GYOutDatumNone f (Api.TxOutDatumHash _ hash) = GYOutDatumHash $ datumHashFromApi hash f (Api.TxOutDatumInline _ sd) = GYOutDatumInline $ datumFromApi' sd utxoToPlutus :: GYUTxO -> Plutus.TxOut -utxoToPlutus GYUTxO{..} = Plutus.TxOut - { Plutus.txOutAddress = addressToPlutus utxoAddress - , Plutus.txOutValue = valueToPlutus utxoValue - , Plutus.txOutDatum = outDatumToPlutus utxoOutDatum +utxoToPlutus GYUTxO {..} = + Plutus.TxOut + { Plutus.txOutAddress = addressToPlutus utxoAddress + , Plutus.txOutValue = valueToPlutus utxoValue + , Plutus.txOutDatum = outDatumToPlutus utxoOutDatum , Plutus.txOutReferenceScript = scriptHashToPlutus . hashAnyScript <$> utxoRefScript } -- | Whether the UTxO has it's datum inlined? utxoHasInlineDatum :: GYUTxO -> Bool -utxoHasInlineDatum = isInlineDatum . utxoOutDatum +utxoHasInlineDatum = isInlineDatum . utxoOutDatum -- | Whether the UTxO has script to refer? utxoHasReferenceScript :: GYUTxO -> Bool @@ -190,10 +201,10 @@ utxoTranslatableToV1 u = not (utxoHasReferenceScript u) && not (utxoHasInlineDat utxosSize :: GYUTxOs -> Int utxosSize (GYUTxOs m) = Map.size m --- | Remove particular 'GYTxOutRef' from 'GYUTxOs'. --- --- Used to remove collateral, so we don't use it in transactions. --- +{- | Remove particular 'GYTxOutRef' from 'GYUTxOs'. + +Used to remove collateral, so we don't use it in transactions. +-} utxosRemoveTxOutRef :: GYTxOutRef -> GYUTxOs -> GYUTxOs utxosRemoveTxOutRef oref (GYUTxOs m) = GYUTxOs $ Map.delete oref m @@ -217,32 +228,36 @@ utxosRemoveUTxOs (GYUTxOs m) (GYUTxOs m') = GYUTxOs $ m Map.\\ m' utxosLookup :: GYTxOutRef -> GYUTxOs -> Maybe GYUTxO utxosLookup r (GYUTxOs m) = (\(a, v, mh, ms) -> GYUTxO r a v mh ms) <$> Map.lookup r m --- | Get some output reference from 'GYUTxOs'. --- --- Used to pick an input for minting, or selecting collateral (in tests). --- +{- | Get some output reference from 'GYUTxOs'. + +Used to pick an input for minting, or selecting collateral (in tests). +-} someTxOutRef :: GYUTxOs -> Maybe (GYTxOutRef, GYUTxOs) -someTxOutRef (GYUTxOs m) = f <$> Map.minViewWithKey m where +someTxOutRef (GYUTxOs m) = f <$> Map.minViewWithKey m + where f ((oref, _), m') = (oref, GYUTxOs m') -- | Get a random output reference from 'GYUTxOs'. -randomTxOutRef :: MonadRandom m => GYUTxOs -> m (Maybe (GYTxOutRef, GYUTxOs)) +randomTxOutRef :: (MonadRandom m) => GYUTxOs -> m (Maybe (GYTxOutRef, GYUTxOs)) randomTxOutRef (GYUTxOs m) | Map.null m = pure Nothing - | otherwise = Just <$> do - ix <- getRandomR (0, Map.size m - 1) - let entry = fst $ Map.elemAt ix m - let remainder = Map.deleteAt ix m - pure (entry, GYUTxOs remainder) + | otherwise = + Just <$> do + ix <- getRandomR (0, Map.size m - 1) + let entry = fst $ Map.elemAt ix m + let remainder = Map.deleteAt ix m + pure (entry, GYUTxOs remainder) -- | Filter 'GYUTxOs' with a predicate on 'GYUTxO'. filterUTxOs :: (GYUTxO -> Bool) -> GYUTxOs -> GYUTxOs -filterUTxOs p (GYUTxOs m) = GYUTxOs $ Map.filterWithKey p' m where +filterUTxOs p (GYUTxOs m) = GYUTxOs $ Map.filterWithKey p' m + where p' r (a, v, mh, ms) = p $ GYUTxO r a v mh ms -- | Map & filter 'GYUTxOs' contents. mapMaybeUTxOs :: (GYUTxO -> Maybe a) -> GYUTxOs -> Map GYTxOutRef a -mapMaybeUTxOs p (GYUTxOs m) = Map.mapMaybeWithKey p' m where +mapMaybeUTxOs p (GYUTxOs m) = Map.mapMaybeWithKey p' m + where p' r (a, v, mh, ms) = p $ GYUTxO r a v mh ms -- | Map 'GYUTxOs' contents. @@ -250,16 +265,19 @@ mapUTxOs :: (GYUTxO -> a) -> GYUTxOs -> Map GYTxOutRef a mapUTxOs f = mapMaybeUTxOs $ Just . f -- | Applicative version of 'mapMaybeUTxOs'. -witherUTxOs :: Applicative f => (GYUTxO -> f (Maybe a)) -> GYUTxOs -> f (Map GYTxOutRef a) -witherUTxOs f (GYUTxOs m) = iwither g m where +witherUTxOs :: (Applicative f) => (GYUTxO -> f (Maybe a)) -> GYUTxOs -> f (Map GYTxOutRef a) +witherUTxOs f (GYUTxOs m) = iwither g m + where g ref (a, v, mh, ms) = f (GYUTxO ref a v mh ms) -- | Returns a 'GYUTxOs' from a given list of 'GYUTxO's. utxosFromList :: [GYUTxO] -> GYUTxOs -utxosFromList xs = GYUTxOs $ Map.fromList - [ (r, (a, v, mh, ms)) - | GYUTxO r a v mh ms <- xs - ] +utxosFromList xs = + GYUTxOs $ + Map.fromList + [ (r, (a, v, mh, ms)) + | GYUTxO r a v mh ms <- xs + ] -- | Returns a list of 'GYUTxO's from a given 'GYUTxOs'. utxosToList :: GYUTxOs -> [GYUTxO] @@ -281,23 +299,25 @@ foldlUTxOs' f x (GYUTxOs m) = Map.foldlWithKey' f' x m f' y r (a, v, mh, ms) = f y $ GYUTxO r a v mh ms -- | FoldMap operation over a 'GYUTxOs'. -foldMapUTxOs :: Monoid m => (GYUTxO -> m) -> GYUTxOs -> m +foldMapUTxOs :: (Monoid m) => (GYUTxO -> m) -> GYUTxOs -> m foldMapUTxOs f = foldlUTxOs' (\m utxo -> m <> f utxo) mempty -forUTxOs_ :: forall f a. Applicative f => GYUTxOs -> (GYUTxO -> f a) -> f () +forUTxOs_ :: forall f a. (Applicative f) => GYUTxOs -> (GYUTxO -> f a) -> f () forUTxOs_ (GYUTxOs m) f = ifor_ m f' where f' :: GYTxOutRef -> (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> f a f' r (a, v, mh, ms) = f $ GYUTxO r a v mh ms -foldMUTxOs :: forall m a. Monad m => (a -> GYUTxO -> m a) -> a -> GYUTxOs -> m a +foldMUTxOs :: forall m a. (Monad m) => (a -> GYUTxO -> m a) -> a -> GYUTxOs -> m a foldMUTxOs f x (GYUTxOs m) = foldM f' x $ Map.toList m where f' :: a -> (GYTxOutRef, (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript)) -> m a f' y (r, (a, v, mh, ms)) = f y $ GYUTxO r a v mh ms instance Printf.PrintfArg GYUTxOs where - formatArg (GYUTxOs m) = Printf.formatArg $ unlines + formatArg (GYUTxOs m) = + Printf.formatArg $ + unlines [ Printf.printf "%s %s" oref v | (oref, (_, v, _, _)) <- Map.toList m ] diff --git a/src/GeniusYield/Types/Value.hs b/src/GeniusYield/Types/Value.hs index 19b84f7a..9159016a 100644 --- a/src/GeniusYield/Types/Value.hs +++ b/src/GeniusYield/Types/Value.hs @@ -1,121 +1,131 @@ -{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-| + +{- | Module : GeniusYield.Types.Value Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module GeniusYield.Types.Value ( - -- * Value - GYValue, - valueMake, - valueToPlutus, - valueFromPlutus, - valueToApi, - valueFromApi, - valueSingleton, - valueFromList, - valueToList, - valueToMap, - valueMap, - valueTotalAssets, - valueInsert, - valueAdjust, - valueFromLovelace, - valueFromApiTxOutValue, - valueToApiTxOutValue, - valueAssets, - parseValueKM, - -- ** Arithmetic - valueMinus, - valueNegate, - valuePositive, - valueNonNegative, - valueGreaterOrEqual, - valueGreater, - -- ** Unions & Intersections - valueUnionWith, - valueIntersection, - valueIntersectionWith, - -- ** Lookup - valueAssetClass, - -- ** Splitting - valueSplitAda, - valueSplitSign, - -- ** Predicates - isEmptyValue, - valueVerifyNonNegative, - -- ** Debug - valueValid, - -- ** Conversion errors - GYFromPlutusValueError (..), - -- * Asset class - GYAssetClass (..), - assetClassToPlutus, - assetClassFromPlutus, - parseAssetClassWithSep, - parseAssetClassWithoutSep, - parseAssetClassCore, - -- * Token name - GYTokenName(..), - tokenNameToHex, - tokenNameFromBS, - tokenNameToPlutus, - tokenNameFromPlutus, - tokenNameFromHex, - unsafeTokenNameFromHex, - makeAssetClass + -- * Value + GYValue, + valueMake, + valueToPlutus, + valueFromPlutus, + valueToApi, + valueFromApi, + valueSingleton, + valueFromList, + valueToList, + valueToMap, + valueMap, + valueTotalAssets, + valueInsert, + valueAdjust, + valueFromLovelace, + valueFromApiTxOutValue, + valueToApiTxOutValue, + valueAssets, + parseValueKM, + + -- ** Arithmetic + valueMinus, + valueNegate, + valuePositive, + valueNonNegative, + valueGreaterOrEqual, + valueGreater, + + -- ** Unions & Intersections + valueUnionWith, + valueIntersection, + valueIntersectionWith, + + -- ** Lookup + valueAssetClass, + + -- ** Splitting + valueSplitAda, + valueSplitSign, + + -- ** Predicates + isEmptyValue, + valueVerifyNonNegative, + + -- ** Debug + valueValid, + + -- ** Conversion errors + GYFromPlutusValueError (..), + + -- * Asset class + GYAssetClass (..), + assetClassToPlutus, + assetClassFromPlutus, + parseAssetClassWithSep, + parseAssetClassWithoutSep, + parseAssetClassCore, + + -- * Token name + GYTokenName (..), + tokenNameToHex, + tokenNameFromBS, + tokenNameToPlutus, + tokenNameFromPlutus, + tokenNameFromHex, + unsafeTokenNameFromHex, + makeAssetClass, ) where -import qualified Cardano.Ledger.Coin as Ledger -import Control.Lens ((?~)) -import Data.Aeson (object, (.=)) -import qualified Data.Aeson.Key as K -import qualified Data.Aeson.KeyMap as KM -import qualified Data.Csv as Csv -import Data.List (intercalate) -import qualified Data.Scientific as SC -import GeniusYield.Imports -import PlutusTx.Builtins (fromBuiltin, toBuiltin) - -import qualified Cardano.Api as Api +import Cardano.Ledger.Coin qualified as Ledger +import Control.Lens ((?~)) +import Data.Aeson (object, (.=)) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Csv qualified as Csv +import Data.List (intercalate) +import Data.Scientific qualified as SC +import GeniusYield.Imports +import PlutusTx.Builtins (fromBuiltin, toBuiltin) + +import Cardano.Api qualified as Api + -- import qualified Cardano.Api.Value as Api -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson -import qualified Data.Attoparsec.ByteString.Char8 as Atto -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map.Strict as Map -import qualified Data.Swagger as Swagger -import qualified Data.Swagger.Internal.Schema as Swagger -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified PlutusLedgerApi.V1.Value as Plutus -import qualified Text.Printf as Printf -import qualified Web.HttpApiData as Web - - -import Data.Either.Combinators (mapLeft) -import Data.Foldable (for_) -import Data.Hashable (Hashable (..)) -import qualified GeniusYield.Types.Ada as Ada -import GeniusYield.Types.Era -import GeniusYield.Types.Script - --- $setup --- --- >>> :set -XOverloadedStrings -XTypeApplications --- >>> import qualified Cardano.Api as Api --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.ByteString.Char8 as BS8 --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 --- >>> import qualified Data.Csv as Csv --- >>> import qualified Text.Printf as Printf --- >>> import qualified Web.HttpApiData as Web +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson +import Data.Attoparsec.ByteString.Char8 qualified as Atto +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as Base16 +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Swagger qualified as Swagger +import Data.Swagger.Internal.Schema qualified as Swagger +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import PlutusLedgerApi.V1.Value qualified as Plutus +import Text.Printf qualified as Printf +import Web.HttpApiData qualified as Web + +import Data.Either.Combinators (mapLeft) +import Data.Foldable (for_) +import Data.Hashable (Hashable (..)) +import GeniusYield.Types.Ada qualified as Ada +import GeniusYield.Types.Era +import GeniusYield.Types.Script + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Cardano.Api as Api +>>> import qualified Data.Aeson as Aeson +>>> import qualified Data.ByteString.Char8 as BS8 +>>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +>>> import qualified Data.Csv as Csv +>>> import qualified Text.Printf as Printf +>>> import qualified Web.HttpApiData as Web +-} ------------------------------------------------------------------------------- -- Value @@ -123,20 +133,21 @@ import GeniusYield.Types.Script -- | Errors raised during 'Plutus.Value' -> 'GYValue' conversion. data GYFromPlutusValueError - -- | Length of the token name bytestring is more than 32. - = GYTokenNameTooBig !Plutus.TokenName - -- | PolicyId deserialization failure. - | GYInvalidPolicyId !Plutus.CurrencySymbol - deriving (Show, Eq) + = -- | Length of the token name bytestring is more than 32. + GYTokenNameTooBig !Plutus.TokenName + | -- | PolicyId deserialization failure. + GYInvalidPolicyId !Plutus.CurrencySymbol + deriving (Show, Eq) -- | Value: a (total) map from asset classes ('GYAssetClass') to amount ('Integer'). newtype GYValue = GYValue (Map.Map GYAssetClass Integer) - deriving Eq - deriving newtype Ord + deriving (Eq) + deriving newtype (Ord) + +{- | Check the 'GYValue' representation invariants. --- | Check the 'GYValue' representation invariants. --- --- Should always evaluate to 'True' +Should always evaluate to 'True' +-} valueValid :: GYValue -> Bool valueValid (GYValue v) = 0 `notElem` v -- invariant: zero integers are not stored. @@ -145,59 +156,65 @@ valueMake :: Map.Map GYAssetClass Integer -> GYValue valueMake m = GYValue (Map.filter (/= 0) m) instance Show GYValue where - showsPrec d v = showParen (d > 10) - $ showString "valueFromList " + showsPrec d v = + showParen (d > 10) $ + showString "valueFromList " . showsPrec 11 (valueToList v) instance Semigroup GYValue where - GYValue x <> GYValue y = valueMake $ Map.unionWith (+) x y + GYValue x <> GYValue y = valueMake $ Map.unionWith (+) x y instance Monoid GYValue where - mempty = GYValue Map.empty + mempty = GYValue Map.empty -- | Converts a 'GYValue' to a Plutus 'Plutus.Value' valueToPlutus :: GYValue -> Plutus.Value -valueToPlutus (GYValue m) = foldMap f (Map.toList m) where +valueToPlutus (GYValue m) = foldMap f (Map.toList m) + where f :: (GYAssetClass, Integer) -> Plutus.Value f (assetClassToPlutus -> Plutus.AssetClass (cs, tn), n) = Plutus.singleton cs tn n --- | Converts a Plutus 'Plutus.Value' to a 'GYValue'. --- Returns Left 'GYFromPlutusValueError' if it fails. -valueFromPlutus :: Plutus.Value -> Either GYFromPlutusValueError GYValue +{- | Converts a Plutus 'Plutus.Value' to a 'GYValue'. + Returns Left 'GYFromPlutusValueError' if it fails. +-} +valueFromPlutus :: Plutus.Value -> Either GYFromPlutusValueError GYValue valueFromPlutus v = fmap valueFromList $ - forM (Plutus.flattenValue v) $ \(cs, tn, n) -> do - ac <- assetClassFromPlutus (Plutus.AssetClass (cs, tn)) - return (ac, n) - --- | --- --- >>> valueFromLovelace 0 --- valueFromList [] --- --- >>> valueFromLovelace 100 --- valueFromList [(GYLovelace,100)] --- + forM (Plutus.flattenValue v) $ \(cs, tn, n) -> do + ac <- assetClassFromPlutus (Plutus.AssetClass (cs, tn)) + return (ac, n) + +{- | + +>>> valueFromLovelace 0 +valueFromList [] + +>>> valueFromLovelace 100 +valueFromList [(GYLovelace,100)] +-} valueFromLovelace :: Integer -> GYValue valueFromLovelace 0 = GYValue mempty valueFromLovelace i = GYValue (Map.singleton GYLovelace i) --- | Returns a 'GYValue' containing only the given 'GYAssetClass' with the given amount. --- --- >>> valueSingleton (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD") 100 --- valueFromList [(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",100)] +{- | Returns a 'GYValue' containing only the given 'GYAssetClass' with the given amount. + +>>> valueSingleton (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD") 100 +valueFromList [(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",100)] +-} valueSingleton :: GYAssetClass -> Integer -> GYValue valueSingleton ac n = valueMake $ Map.singleton ac n -- | Convert a 'GYValue' to a Cardano Api 'Api.Value' valueToApi :: GYValue -> Api.Value -valueToApi v = Api.valueFromList +valueToApi v = + Api.valueFromList [ (assetClassToApi ac, Api.Quantity n) | (ac, n) <- valueToList v ] -- | Convert a Cardano Api 'Api.Value' to a 'GYValue' valueFromApi :: Api.Value -> GYValue -valueFromApi v = valueFromList +valueFromApi v = + valueFromList [ (assetClassFromApi ac, n) | (ac, Api.Quantity n) <- Api.valueToList v ] @@ -213,9 +230,9 @@ valueToApiTxOutValue v = Api.ShelleyBasedEraConway (Api.toLedgerValue Api.MaryEraOnwardsConway $ valueToApi v) --- | Create 'GYValue' from a list of asset class and amount. --- Duplicates are merged. --- +{- | Create 'GYValue' from a list of asset class and amount. +Duplicates are merged. +-} valueFromList :: [(GYAssetClass, Integer)] -> GYValue valueFromList xs = valueMake $ Map.fromListWith (+) xs @@ -247,16 +264,17 @@ valueAssets (GYValue m) = Map.keysSet m -- | Returns the total count of assets in a given 'GYValue' valueTotalAssets :: GYValue -> Int valueTotalAssets (GYValue v) = Map.size v --- | --- --- >>> Printf.printf "value = %s" (valueFromList []) --- value = --- --- >>> Printf.printf "value = %s" (valueFromList [(GYLovelace, 1000)]) --- value = 1000 lovelace --- + +{- | + +>>> Printf.printf "value = %s" (valueFromList []) +value = + +>>> Printf.printf "value = %s" (valueFromList [(GYLovelace, 1000)]) +value = 1000 lovelace +-} instance Printf.PrintfArg GYValue where - formatArg v = Printf.formatArg (showValue (valueToPlutus v)) + formatArg v = Printf.formatArg (showValue (valueToPlutus v)) showValue :: Plutus.Value -> String showValue = intercalate " + " . map f . Plutus.flattenValue @@ -264,74 +282,81 @@ showValue = intercalate " + " . map f . Plutus.flattenValue f :: (Plutus.CurrencySymbol, Plutus.TokenName, Integer) -> String f (cs, tn, n) = show n ++ " " ++ showAssetClass (Plutus.AssetClass (cs, tn)) --- | --- --- >>> LBS8.putStrLn . Aeson.encode . valueFromList $ [(GYLovelace,22),(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",101)] --- {"lovelace":22,"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.474f4c44":101} --- -instance Aeson.ToJSON GYValue where - toJSON = object . map (uncurry assetPairToKV) . valueToList - toEncoding = Aeson.pairs . foldMap (uncurry assetPairToKV) . valueToList +{- | +>>> LBS8.putStrLn . Aeson.encode . valueFromList $ [(GYLovelace,22),(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",101)] +{"lovelace":22,"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.474f4c44":101} +-} +instance Aeson.ToJSON GYValue where + toJSON = object . map (uncurry assetPairToKV) . valueToList + toEncoding = Aeson.pairs . foldMap (uncurry assetPairToKV) . valueToList instance Csv.ToField GYValue where - toField = LBS.toStrict . Aeson.encode + toField = LBS.toStrict . Aeson.encode instance Csv.FromField GYValue where - parseField value = - case Aeson.decode $ LBS.fromStrict value of - Just v -> pure v - Nothing -> fail $ "Error Parsing GYValue: " <> show value + parseField value = + case Aeson.decode $ LBS.fromStrict value of + Just v -> pure v + Nothing -> fail $ "Error Parsing GYValue: " <> show value - -assetPairToKV :: Aeson.KeyValue e kv => GYAssetClass -> Integer -> kv +assetPairToKV :: (Aeson.KeyValue e kv) => GYAssetClass -> Integer -> kv assetPairToKV ac i = K.fromText (f ac) .= i where - f GYLovelace = "lovelace" + f GYLovelace = "lovelace" f (GYToken cs tk) = mintingPolicyIdToText cs <> T.cons '.' (tokenNameToHex tk) --- | --- --- >>> Aeson.decode @GYValue "{\"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.474f4c44\":101,\"lovelace\":22}" --- Just (valueFromList [(GYLovelace,22),(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",101)]) --- -instance Aeson.FromJSON GYValue where -- TODO: Do we need this? Can't this be derived from newtype? +{- | + +>>> Aeson.decode @GYValue "{\"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.474f4c44\":101,\"lovelace\":22}" +Just (valueFromList [(GYLovelace,22),(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",101)]) +-} +instance Aeson.FromJSON GYValue where -- TODO: Do we need this? Can't this be derived from newtype? parseJSON = Aeson.withObject "GYValue" $ parseValueKM False -- | Parse a 'GYValue' from a JSON object. -parseValueKM - :: Bool - -- ^ Attempt to try parsing without separator in asset class when parsing fails with separator. - -> KM.KeyMap Aeson.Value - -- ^ JSON object. - -> Aeson.Parser GYValue +parseValueKM :: + -- | Attempt to try parsing without separator in asset class when parsing fails with separator. + Bool -> + -- | JSON object. + KM.KeyMap Aeson.Value -> + Aeson.Parser GYValue parseValueKM allowWithoutSep km = - case KM.toList km of - [] -> pure $ valueMake mempty - xs -> valueFromList <$> traverse go xs + case KM.toList km of + [] -> pure $ valueMake mempty + xs -> valueFromList <$> traverse go xs where go :: (Aeson.Key, Aeson.Value) -> Aeson.Parser (GYAssetClass, Integer) go (k, v) = do - let k' = K.toText k - parseWithSep = parseAssetClassWithSep '.' k' - ac <- either fail pure $ - either (\(Left -> e) -> if allowWithoutSep then parseAssetClassWithoutSep k' <> e else e) Right parseWithSep - scN <- parseJSON v - case SC.floatingOrInteger @Double scN of - Left d -> fail $ "Expected amount to be an integer; amount: " <> show d - Right i -> pure (ac, i) + let k' = K.toText k + parseWithSep = parseAssetClassWithSep '.' k' + ac <- + either fail pure $ + either (\(Left -> e) -> if allowWithoutSep then parseAssetClassWithoutSep k' <> e else e) Right parseWithSep + scN <- parseJSON v + case SC.floatingOrInteger @Double scN of + Left d -> fail $ "Expected amount to be an integer; amount: " <> show d + Right i -> pure (ac, i) instance Swagger.ToSchema GYValue where - declareNamedSchema _ = do - integerSchema <- Swagger.declareSchemaRef @Integer Proxy - pure $ Swagger.named "GYValue" $ mempty - & Swagger.type_ ?~ Swagger.SwaggerObject - & Swagger.example ?~ toJSON (valueFromList - [ (GYLovelace, 22) - , (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD", 101) - ]) - & Swagger.description ?~ "A multi asset quantity, represented as map where each key represents an asset: policy ID and token name in hex concatenated by a dot." - & Swagger.additionalProperties ?~ Swagger.AdditionalPropertiesSchema integerSchema + declareNamedSchema _ = do + integerSchema <- Swagger.declareSchemaRef @Integer Proxy + pure $ + Swagger.named "GYValue" $ + mempty + & Swagger.type_ + ?~ Swagger.SwaggerObject + & Swagger.example + ?~ toJSON + ( valueFromList + [ (GYLovelace, 22) + , (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD", 101) + ] + ) + & Swagger.description + ?~ "A multi asset quantity, represented as map where each key represents an asset: policy ID and token name in hex concatenated by a dot." + & Swagger.additionalProperties + ?~ Swagger.AdditionalPropertiesSchema integerSchema ------------------------------------------------------------------------------- -- Arithmetic @@ -361,14 +386,14 @@ valueGreaterOrEqual v w = valueNonNegative $ v `valueMinus` w valueGreater :: GYValue -> GYValue -> Bool valueGreater v w = valuePositive $ v `valueMinus` w --- | Splits a 'GYValue' into the lovelace amount and the rest of it's components. --- --- >>> valueSplitAda $ valueFromLovelace 100 --- (100,valueFromList []) --- --- >>> valueSplitAda $ valueFromList [(GYLovelace, 100), (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",101)] --- (100,valueFromList [(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",101)]) --- +{- | Splits a 'GYValue' into the lovelace amount and the rest of it's components. + +>>> valueSplitAda $ valueFromLovelace 100 +(100,valueFromList []) + +>>> valueSplitAda $ valueFromList [(GYLovelace, 100), (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",101)] +(100,valueFromList [(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",101)]) +-} valueSplitAda :: GYValue -> (Integer, GYValue) valueSplitAda (GYValue m) = (Map.findWithDefault 0 GYLovelace m, GYValue (Map.delete GYLovelace m)) @@ -376,20 +401,20 @@ valueSplitAda (GYValue m) = (Map.findWithDefault 0 GYLovelace m, GYValue (Map.de valueAssetClass :: GYValue -> GYAssetClass -> Integer valueAssetClass (GYValue m) ac = Map.findWithDefault 0 ac m --- | Split a 'GYValue' into its positive and negative components. The first element of --- the pair is the positive components of the value. The second element is the negative component. --- --- >>> valueSplitSign $ valueFromList [(GYLovelace,22),(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",-10)] --- (valueFromList [(GYLovelace,22)],valueFromList [(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",10)]) --- +{- | Split a 'GYValue' into its positive and negative components. The first element of + the pair is the positive components of the value. The second element is the negative component. + +>>> valueSplitSign $ valueFromList [(GYLovelace,22),(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",-10)] +(valueFromList [(GYLovelace,22)],valueFromList [(GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD",10)]) +-} valueSplitSign :: GYValue -> (GYValue, GYValue) valueSplitSign (GYValue m) = (GYValue positiveVal, GYValue $ negate <$> negativeVal) where - (positiveVal, negativeVal) = Map.partition (>0) m + (positiveVal, negativeVal) = Map.partition (> 0) m -- | Verify the value only consists of positive amounts, returning a map containing naturals as a result. valueVerifyNonNegative :: GYValue -> Maybe (Map GYAssetClass Natural) -valueVerifyNonNegative (GYValue m) = if all (>=0) m then Just $ fromIntegral <$> m else Nothing +valueVerifyNonNegative (GYValue m) = if all (>= 0) m then Just $ fromIntegral <$> m else Nothing ------------------------------------------------------------------------------- -- Unions & Intersections @@ -414,17 +439,17 @@ valueIntersectionWith f (GYValue m1) (GYValue m2) = valueMake $ Map.intersection -- Predicates ------------------------------------------------------------------------------- --- | Checks if the given 'GYValue' is empty --- --- >>> isEmptyValue mempty --- True --- --- >>> isEmptyValue $ valueFromLovelace 100 --- False --- --- >>> isEmptyValue $ valueMinus (valueFromLovelace 100) (valueFromLovelace 100) --- True --- +{- | Checks if the given 'GYValue' is empty + +>>> isEmptyValue mempty +True + +>>> isEmptyValue $ valueFromLovelace 100 +False + +>>> isEmptyValue $ valueMinus (valueFromLovelace 100) (valueFromLovelace 100) +True +-} isEmptyValue :: GYValue -> Bool isEmptyValue (GYValue m) = Map.null m @@ -433,310 +458,327 @@ isEmptyValue (GYValue m) = Map.null m ------------------------------------------------------------------------------- -- | Asset class. Either lovelace or minted token. --- data GYAssetClass = GYLovelace | GYToken GYMintingPolicyId GYTokenName deriving stock (Show, Eq, Ord, Generic) instance Hashable GYAssetClass where - hashWithSalt salt ac = hashWithSalt salt $ Web.toUrlPiece ac + hashWithSalt salt ac = hashWithSalt salt $ Web.toUrlPiece ac instance Aeson.ToJSONKey GYAssetClass where - toJSONKey = Aeson.toJSONKeyText Web.toUrlPiece + toJSONKey = Aeson.toJSONKeyText Web.toUrlPiece instance Aeson.FromJSONKey GYAssetClass where - fromJSONKey = Aeson.FromJSONKeyTextParser (either (fail . show) pure . Web.parseUrlPiece) + fromJSONKey = Aeson.FromJSONKeyTextParser (either (fail . show) pure . Web.parseUrlPiece) instance Swagger.ToParamSchema GYAssetClass where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString instance Swagger.ToSchema GYAssetClass where declareNamedSchema p = do - return $ Swagger.named "GYAssetClass" $ - Swagger.paramSchemaToSchema p - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.description ?~ "This is an asset class, i.e. either \"lovelace\" or some other token with its minting policy and token name delimited by dot (.)." - & Swagger.example ?~ toJSON ("ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.474f4c44" :: Text) + return $ + Swagger.named "GYAssetClass" $ + Swagger.paramSchemaToSchema p + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.description + ?~ "This is an asset class, i.e. either \"lovelace\" or some other token with its minting policy and token name delimited by dot (.)." + & Swagger.example + ?~ toJSON ("ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.474f4c44" :: Text) -- | Converts a 'GYAssetClass' into a Plutus 'Plutus.AssetClass'. assetClassToPlutus :: GYAssetClass -> Plutus.AssetClass -assetClassToPlutus GYLovelace = Plutus.AssetClass (Ada.adaSymbol, Ada.adaToken) +assetClassToPlutus GYLovelace = Plutus.AssetClass (Ada.adaSymbol, Ada.adaToken) assetClassToPlutus (GYToken cs tn) = Plutus.AssetClass (mintingPolicyIdToCurrencySymbol cs, tokenNameToPlutus tn) --- | Converts a Plutus 'Plutus.AssetClass' into a 'GYAssetClass'. --- Returns Left 'GYFromPlutusValueError' if it fails. +{- | Converts a Plutus 'Plutus.AssetClass' into a 'GYAssetClass'. +Returns Left 'GYFromPlutusValueError' if it fails. +-} assetClassFromPlutus :: Plutus.AssetClass -> Either GYFromPlutusValueError GYAssetClass assetClassFromPlutus (Plutus.AssetClass (cs, tn)) - | cs == Ada.adaSymbol, tn == Ada.adaToken = Right GYLovelace - | otherwise = do - tn' <- maybe (Left $ GYTokenNameTooBig tn) Right $ tokenNameFromPlutus tn - cs' <- mapLeft (\_ -> GYInvalidPolicyId cs) . Api.deserialiseFromRawBytes Api.AsScriptHash $ - case cs of Plutus.CurrencySymbol bs -> fromBuiltin bs - return (GYToken (mintingPolicyIdFromApi (Api.PolicyId cs')) tn') + | cs == Ada.adaSymbol, tn == Ada.adaToken = Right GYLovelace + | otherwise = do + tn' <- maybe (Left $ GYTokenNameTooBig tn) Right $ tokenNameFromPlutus tn + cs' <- mapLeft (\_ -> GYInvalidPolicyId cs) . Api.deserialiseFromRawBytes Api.AsScriptHash $ + case cs of Plutus.CurrencySymbol bs -> fromBuiltin bs + return (GYToken (mintingPolicyIdFromApi (Api.PolicyId cs')) tn') -- | Converts a 'GYAssetClass' into a Cardano Api 'Api.AssetId'. assetClassToApi :: GYAssetClass -> Api.AssetId -assetClassToApi GYLovelace = Api.AdaAssetId +assetClassToApi GYLovelace = Api.AdaAssetId assetClassToApi (GYToken cs tn) = Api.AssetId (mintingPolicyIdToApi cs) (tokenNameToApi tn) -- | Converts a Cardano Api 'Api.AssetId' into a 'GYAssetClass'. assetClassFromApi :: Api.AssetId -> GYAssetClass -assetClassFromApi Api.AdaAssetId = GYLovelace +assetClassFromApi Api.AdaAssetId = GYLovelace assetClassFromApi (Api.AssetId cs tn) = GYToken (mintingPolicyIdFromApi cs) (tokenNameFromApi tn) instance IsString GYAssetClass where - fromString s = case Web.parseUrlPiece $ T.pack s of - Left err -> error $ T.unpack err - Right x -> x - --- | --- --- >>> Printf.printf "ac = %s" GYLovelace --- ac = lovelace --- + fromString s = case Web.parseUrlPiece $ T.pack s of + Left err -> error $ T.unpack err + Right x -> x + +{- | + +>>> Printf.printf "ac = %s" GYLovelace +ac = lovelace +-} instance Printf.PrintfArg GYAssetClass where - formatArg ac = Printf.formatArg (showAssetClass (assetClassToPlutus ac)) + formatArg ac = Printf.formatArg (showAssetClass (assetClassToPlutus ac)) showAssetClass :: Plutus.AssetClass -> String showAssetClass (Plutus.AssetClass (cs, tn)) - | cs == Ada.adaSymbol && tn == Ada.adaToken = "lovelace" - | otherwise = case tokenNameFromPlutus tn of - Nothing -> error $ "invalid token name: " <> show tn - Just tn' -> show cs <> "." <> T.unpack (tokenNameToHex tn') - --- | --- --- >>> Web.toUrlPiece GYLovelace --- "lovelace" --- --- >>> Web.toUrlPiece (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD") --- "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.474f4c44" --- --- >>> let tn = unsafeTokenNameFromHex "0014df1043727970746f20556e69636f726e" in Web.toUrlPiece (GYToken "ecda51cf797535f5661a8ade59170d6f3ee7623be5789b58fac583f0" tn) --- "ecda51cf797535f5661a8ade59170d6f3ee7623be5789b58fac583f0.0014df1043727970746f20556e69636f726e" --- + | cs == Ada.adaSymbol && tn == Ada.adaToken = "lovelace" + | otherwise = case tokenNameFromPlutus tn of + Nothing -> error $ "invalid token name: " <> show tn + Just tn' -> show cs <> "." <> T.unpack (tokenNameToHex tn') + +{- | + +>>> Web.toUrlPiece GYLovelace +"lovelace" + +>>> Web.toUrlPiece (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GOLD") +"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.474f4c44" + +>>> let tn = unsafeTokenNameFromHex "0014df1043727970746f20556e69636f726e" in Web.toUrlPiece (GYToken "ecda51cf797535f5661a8ade59170d6f3ee7623be5789b58fac583f0" tn) +"ecda51cf797535f5661a8ade59170d6f3ee7623be5789b58fac583f0.0014df1043727970746f20556e69636f726e" +-} instance Web.ToHttpApiData GYAssetClass where - toUrlPiece = T.pack . showAssetClass . assetClassToPlutus - --- | Note: not used currently by API (tests only) --- --- >>> Web.parseUrlPiece @GYAssetClass "lovelace" --- Right GYLovelace --- --- >>> Web.parseUrlPiece @GYAssetClass "" --- Right GYLovelace --- --- >>> Web.parseUrlPiece @GYAssetClass "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64" --- Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") --- + toUrlPiece = T.pack . showAssetClass . assetClassToPlutus + +{- | Note: not used currently by API (tests only) + +>>> Web.parseUrlPiece @GYAssetClass "lovelace" +Right GYLovelace + +>>> Web.parseUrlPiece @GYAssetClass "" +Right GYLovelace + +>>> Web.parseUrlPiece @GYAssetClass "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64" +Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") +-} instance Web.FromHttpApiData GYAssetClass where - parseUrlPiece t = first T.pack (parseAssetClassWithSep '.' t) - --- | --- --- >>> LBS8.putStrLn $ Aeson.encode GYLovelace --- "lovelace" --- --- >>> LBS8.putStrLn $ Aeson.encode $ GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold" --- "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64" --- + parseUrlPiece t = first T.pack (parseAssetClassWithSep '.' t) + +{- | + +>>> LBS8.putStrLn $ Aeson.encode GYLovelace +"lovelace" + +>>> LBS8.putStrLn $ Aeson.encode $ GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold" +"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64" +-} instance Aeson.ToJSON GYAssetClass where - toJSON = Aeson.toJSON . showAssetClass . assetClassToPlutus - --- | --- --- >>> Aeson.decode @GYAssetClass "\"lovelace\"" --- Just GYLovelace --- --- >>> Aeson.decode @GYAssetClass "\"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64\"" --- Just (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") --- --- >>> Aeson.decode @GYAssetClass "\"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.0014df1043727970746f20556e69636f726e\"" --- Just (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "\NUL\DC4\223\DLECrypto Unicorn") --- + toJSON = Aeson.toJSON . showAssetClass . assetClassToPlutus + +{- | + +>>> Aeson.decode @GYAssetClass "\"lovelace\"" +Just GYLovelace + +>>> Aeson.decode @GYAssetClass "\"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64\"" +Just (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") + +>>> Aeson.decode @GYAssetClass "\"ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.0014df1043727970746f20556e69636f726e\"" +Just (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "\NUL\DC4\223\DLECrypto Unicorn") +-} instance Aeson.FromJSON GYAssetClass where - parseJSON (Aeson.String t) = either fail return (parseAssetClassWithSep '.' t) - parseJSON v = Aeson.typeMismatch "AssetClass" v - --- | --- --- >>> BS8.putStrLn $ Csv.toField GYLovelace --- lovelace --- --- >>> BS8.putStrLn $ Csv.toField $ GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold" --- ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64 --- + parseJSON (Aeson.String t) = either fail return (parseAssetClassWithSep '.' t) + parseJSON v = Aeson.typeMismatch "AssetClass" v + +{- | + +>>> BS8.putStrLn $ Csv.toField GYLovelace +lovelace + +>>> BS8.putStrLn $ Csv.toField $ GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold" +ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64 +-} instance Csv.ToField GYAssetClass where - toField = encodeUtf8 . T.pack . showAssetClass . assetClassToPlutus - --- | --- --- >>> Csv.runParser @GYAssetClass $ Csv.parseField "lovelace" --- Right GYLovelace --- --- >>> Csv.runParser @GYAssetClass $ Csv.parseField "" --- Right GYLovelace --- --- >>> Csv.runParser @GYAssetClass $ Csv.parseField "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64" --- Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") --- --- >>> Csv.runParser @GYAssetClass $ Csv.parseField "not an asset class" --- Left "not enough input" --- + toField = encodeUtf8 . T.pack . showAssetClass . assetClassToPlutus + +{- | + +>>> Csv.runParser @GYAssetClass $ Csv.parseField "lovelace" +Right GYLovelace + +>>> Csv.runParser @GYAssetClass $ Csv.parseField "" +Right GYLovelace + +>>> Csv.runParser @GYAssetClass $ Csv.parseField "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64" +Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") + +>>> Csv.runParser @GYAssetClass $ Csv.parseField "not an asset class" +Left "not enough input" +-} instance Csv.FromField GYAssetClass where - parseField = either fail return . parseAssetClassWithSep '.' . TE.decodeUtf8Lenient - --- | --- Parse hex encoded currency symbol and hex encoded token name separated by the given separator. --- >>> parseAssetClassWithSep '.' "lovelace" --- Right GYLovelace --- --- >>> parseAssetClassWithSep '.' "" --- Right GYLovelace --- --- >>> parseAssetClassWithSep '.' "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64" --- Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") --- >>> parseAssetClassWithSep '#' "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef#476f6c64" --- Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") --- >>> parseAssetClassWithSep '#' "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef#" --- Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "") --- + parseField = either fail return . parseAssetClassWithSep '.' . TE.decodeUtf8Lenient + +{- | +Parse hex encoded currency symbol and hex encoded token name separated by the given separator. +>>> parseAssetClassWithSep '.' "lovelace" +Right GYLovelace + +>>> parseAssetClassWithSep '.' "" +Right GYLovelace + +>>> parseAssetClassWithSep '.' "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef.476f6c64" +Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") +>>> parseAssetClassWithSep '#' "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef#476f6c64" +Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") +>>> parseAssetClassWithSep '#' "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef#" +Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "") +-} parseAssetClassWithSep :: Char -> Text -> Either String GYAssetClass parseAssetClassWithSep = parseAssetClass . Just --- | --- Parse hex encoded currency symbol and hex encoded token name joined together without any separator. --- >>> parseAssetClassWithoutSep "lovelace" --- Right GYLovelace --- --- >>> parseAssetClassWithoutSep "" --- Right GYLovelace --- --- >>> parseAssetClassWithoutSep "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef476f6c64" --- Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") --- >>> parseAssetClassWithoutSep "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" --- Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "") --- +{- | +Parse hex encoded currency symbol and hex encoded token name joined together without any separator. +>>> parseAssetClassWithoutSep "lovelace" +Right GYLovelace + +>>> parseAssetClassWithoutSep "" +Right GYLovelace + +>>> parseAssetClassWithoutSep "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef476f6c64" +Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "Gold") +>>> parseAssetClassWithoutSep "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" +Right (GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "") +-} parseAssetClassWithoutSep :: Text -> Either String GYAssetClass parseAssetClassWithoutSep = parseAssetClass Nothing parseAssetClass :: Maybe Char -> Text -> Either String GYAssetClass parseAssetClass msep = - case msep of - Just sep -> parseAssetClassCore sep tnParser - Nothing -> parseAssetClassCore' Nothing tnParser + case msep of + Just sep -> parseAssetClassCore sep tnParser + Nothing -> parseAssetClassCore' Nothing tnParser where tnParser tn = - case tokenNameFromHexBS tn of + case tokenNameFromHexBS tn of Left err -> fail $ T.unpack err - Right x -> pure x + Right x -> pure x parseAssetClassCore :: Char -> (BS.ByteString -> Atto.Parser GYTokenName) -> Text -> Either String GYAssetClass parseAssetClassCore = parseAssetClassCore' . Just parseAssetClassCore' :: Maybe Char -> (BS.ByteString -> Atto.Parser GYTokenName) -> Text -> Either String GYAssetClass parseAssetClassCore' _ _ "lovelace" = pure GYLovelace -parseAssetClassCore' _ _ "" = pure GYLovelace +parseAssetClassCore' _ _ "" = pure GYLovelace parseAssetClassCore' msep tkParser t = Atto.parseOnly parser (TE.encodeUtf8 t) where parser :: Atto.Parser GYAssetClass parser = do - cs <- Atto.take 56 - case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of - Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x - Right cs' -> do - for_ msep (void . Atto.char) - tn <- Atto.takeWhile isAlphaNum - GYToken (mintingPolicyIdFromApi cs') <$> tkParser tn + cs <- Atto.take 56 + case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of + Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x + Right cs' -> do + for_ msep (void . Atto.char) + tn <- Atto.takeWhile isAlphaNum + GYToken (mintingPolicyIdFromApi cs') <$> tkParser tn ------------------------------------------------------------------------------- -- TokenName ------------------------------------------------------------------------------- --- | Token name is an arbitrary byte string up to 32 bytes long. --- --- TODO: it's unclear whether it's an arbitrary byte string or UTF8 encoded text #32 --- (which encoded byte form is 32 byte long at most). --- (https://github.com/geniusyield/atlas/issues/32) --- /We treat it as an arbitrary string/. --- --- >>> LBS8.putStrLn $ Aeson.encode ("Gold" :: GYTokenName) --- "476f6c64" --- +{- | Token name is an arbitrary byte string up to 32 bytes long. + +TODO: it's unclear whether it's an arbitrary byte string or UTF8 encoded text #32 +(which encoded byte form is 32 byte long at most). +(https://github.com/geniusyield/atlas/issues/32) +/We treat it as an arbitrary string/. + +>>> LBS8.putStrLn $ Aeson.encode ("Gold" :: GYTokenName) +"476f6c64" +-} newtype GYTokenName = GYTokenName BS.ByteString - deriving stock (Eq, Ord) + deriving stock (Eq, Ord) instance Show GYTokenName where - showsPrec d (GYTokenName s) = showsPrec d s + showsPrec d (GYTokenName s) = showsPrec d s -- | /Does NOT UTF8-encode/. instance IsString GYTokenName where - fromString s = fromMaybe - (error $ "fromString @GYTokenName " ++ show s ++ ": token name too long") - (tokenNameFromBS bs) - where - bs = fromString s -- TODO: utf8-encode #33 (https://github.com/geniusyield/atlas/issues/33) + fromString s = + fromMaybe + (error $ "fromString @GYTokenName " ++ show s ++ ": token name too long") + (tokenNameFromBS bs) + where + bs = fromString s -- TODO: utf8-encode #33 (https://github.com/geniusyield/atlas/issues/33) instance Swagger.ToParamSchema GYTokenName where - toParamSchema _ = mempty - & Swagger.type_ ?~ Swagger.SwaggerString - & Swagger.maxLength ?~ 64 - & Swagger.format ?~ "hex" - & Swagger.pattern ?~ "[0-9a-fA-F]+" + toParamSchema _ = + mempty + & Swagger.type_ + ?~ Swagger.SwaggerString + & Swagger.maxLength + ?~ 64 + & Swagger.format + ?~ "hex" + & Swagger.pattern + ?~ "[0-9a-fA-F]+" instance Swagger.ToSchema GYTokenName where - declareNamedSchema _ = pure $ Swagger.named "GYTokenName" $ Swagger.paramSchemaToSchema (Proxy @GYTokenName) - & Swagger.description ?~ "This is the name of a token." - & Swagger.example ?~ toJSON ("476f6c64" :: Text) - --- | --- --- >>> Aeson.eitherDecode @GYTokenName "\"476f6c64\"" --- Right "Gold" --- --- >>> Aeson.eitherDecode @GYTokenName "\"0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f2021\"" --- Left "Error in $: parseJSON @GYTokenName: token name too long (0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f2021)" --- --- >>> Aeson.eitherDecode @GYTokenName "\"gold\"" --- Left "Error in $: parseJSON @GYTokenName: not base16 encoded (gold)" --- --- >>> Aeson.eitherDecode @GYTokenName "123" --- Left "Error in $: parsing Text failed, expected String, but encountered Number" --- + declareNamedSchema _ = + pure $ + Swagger.named "GYTokenName" $ + Swagger.paramSchemaToSchema (Proxy @GYTokenName) + & Swagger.description + ?~ "This is the name of a token." + & Swagger.example + ?~ toJSON ("476f6c64" :: Text) + +{- | + +>>> Aeson.eitherDecode @GYTokenName "\"476f6c64\"" +Right "Gold" + +>>> Aeson.eitherDecode @GYTokenName "\"0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f2021\"" +Left "Error in $: parseJSON @GYTokenName: token name too long (0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f2021)" + +>>> Aeson.eitherDecode @GYTokenName "\"gold\"" +Left "Error in $: parseJSON @GYTokenName: not base16 encoded (gold)" + +>>> Aeson.eitherDecode @GYTokenName "123" +Left "Error in $: parsing Text failed, expected String, but encountered Number" +-} instance Aeson.FromJSON GYTokenName where - parseJSON v = do - t <- parseJSON v - case Web.parseUrlPiece t of - Right tn -> return tn - Left err -> fail $ "parseJSON @GYTokenName: " <> T.unpack err - --- | --- --- >>> Aeson.encode @GYTokenName "Gold" --- "\"476f6c64\"" --- + parseJSON v = do + t <- parseJSON v + case Web.parseUrlPiece t of + Right tn -> return tn + Left err -> fail $ "parseJSON @GYTokenName: " <> T.unpack err + +{- | + +>>> Aeson.encode @GYTokenName "Gold" +"\"476f6c64\"" +-} instance Aeson.ToJSON GYTokenName where - toJSON = toJSON . tokenNameToHex - toEncoding = toEncoding . tokenNameToHex - --- | --- --- >>> Web.parseUrlPiece @GYTokenName "476f6c64" --- Right "Gold" --- --- >>> Web.parseUrlPiece @GYTokenName "0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f2021" --- Left "token name too long (0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f2021)" --- --- >>> Web.parseUrlPiece @GYTokenName "Gold" --- Left "not base16 encoded (Gold)" --- + toJSON = toJSON . tokenNameToHex + toEncoding = toEncoding . tokenNameToHex + +{- | + +>>> Web.parseUrlPiece @GYTokenName "476f6c64" +Right "Gold" + +>>> Web.parseUrlPiece @GYTokenName "0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f2021" +Left "token name too long (0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f2021)" + +>>> Web.parseUrlPiece @GYTokenName "Gold" +Left "not base16 encoded (Gold)" +-} instance Web.FromHttpApiData GYTokenName where - parseUrlPiece t = case Base16.decode $ TE.encodeUtf8 t of - Right bs -> maybe (Left $ "token name too long (" <> t <> ")") Right $ tokenNameFromBS bs - Left _ -> Left $ "not base16 encoded (" <> t <> ")" + parseUrlPiece t = case Base16.decode $ TE.encodeUtf8 t of + Right bs -> maybe (Left $ "token name too long (" <> t <> ")") Right $ tokenNameFromBS bs + Left _ -> Left $ "not base16 encoded (" <> t <> ")" tokenNameToHex :: GYTokenName -> Text -tokenNameToHex (GYTokenName bs ) = TE.decodeUtf8 $ Base16.encode bs +tokenNameToHex (GYTokenName bs) = TE.decodeUtf8 $ Base16.encode bs -- >>> tokenNameToPlutus "GOLD" -- "GOLD" @@ -745,13 +787,13 @@ tokenNameToPlutus :: GYTokenName -> Plutus.TokenName tokenNameToPlutus (GYTokenName bs) = Plutus.TokenName (toBuiltin bs) -- | Convert Plutus 'Plutus.TokenName' to 'GYTokenName'. -tokenNameFromPlutus :: HasCallStack => Plutus.TokenName -> Maybe GYTokenName +tokenNameFromPlutus :: (HasCallStack) => Plutus.TokenName -> Maybe GYTokenName tokenNameFromPlutus (Plutus.TokenName bbs) = tokenNameFromBS (fromBuiltin bbs) tokenNameFromBS :: BS.ByteString -> Maybe GYTokenName tokenNameFromBS bs - | BS.length bs > 32 = Nothing - | otherwise = Just (GYTokenName bs) + | BS.length bs > 32 = Nothing + | otherwise = Just (GYTokenName bs) tokenNameToApi :: GYTokenName -> Api.AssetName tokenNameToApi = coerce diff --git a/src/GeniusYield/Types/Wallet.hs b/src/GeniusYield/Types/Wallet.hs index 6aa9f524..83619b23 100644 --- a/src/GeniusYield/Types/Wallet.hs +++ b/src/GeniusYield/Types/Wallet.hs @@ -1,52 +1,61 @@ -{-| +{- | Module : GeniusYield.Types.Wallet Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop -} - -module GeniusYield.Types.Wallet - ( WalletKeys - , Mnemonic - , walletKeysFromMnemonic - , walletKeysFromMnemonicWithAccIndex - , walletKeysFromMnemonicIndexed - , walletKeysToExtendedPaymentSigningKey - , walletKeysToExtendedStakeSigningKey - , writeExtendedPaymentSigningKeyTextEnvelope - , writeStakeSigningKeyTextEnvelope - , walletKeysToAddress - ) where - -import Cardano.Address (bech32) -import Cardano.Address.Derivation -import qualified Cardano.Address.Style.Shelley as S -import Cardano.Api -import Cardano.Mnemonic (MkSomeMnemonicError (..), - mkSomeMnemonic) -import qualified Data.Text as T -import Data.Word (Word32) -import GeniusYield.Imports ((&)) -import GeniusYield.Types.Address (GYAddress, - unsafeAddressFromText) -import GeniusYield.Types.Key (GYExtendedPaymentSigningKey, - GYExtendedStakeSigningKey, - extendedPaymentSigningKeyFromApi, - extendedStakeSigningKeyFromApi, - writeExtendedPaymentSigningKey, - writeExtendedStakeSigningKey) -import GeniusYield.Types.NetworkId (GYNetworkId (..)) -import GHC.IO (throwIO) +module GeniusYield.Types.Wallet ( + WalletKeys, + Mnemonic, + walletKeysFromMnemonic, + walletKeysFromMnemonicWithAccIndex, + walletKeysFromMnemonicIndexed, + walletKeysToExtendedPaymentSigningKey, + walletKeysToExtendedStakeSigningKey, + writeExtendedPaymentSigningKeyTextEnvelope, + writeStakeSigningKeyTextEnvelope, + walletKeysToAddress, +) where + +import Cardano.Address (bech32) +import Cardano.Address.Derivation +import Cardano.Address.Style.Shelley qualified as S +import Cardano.Api +import Cardano.Mnemonic ( + MkSomeMnemonicError (..), + mkSomeMnemonic, + ) +import Data.Text qualified as T +import Data.Word (Word32) +import GHC.IO (throwIO) +import GeniusYield.Imports ((&)) +import GeniusYield.Types.Address ( + GYAddress, + unsafeAddressFromText, + ) +import GeniusYield.Types.Key ( + GYExtendedPaymentSigningKey, + GYExtendedStakeSigningKey, + extendedPaymentSigningKeyFromApi, + extendedStakeSigningKeyFromApi, + writeExtendedPaymentSigningKey, + writeExtendedStakeSigningKey, + ) +import GeniusYield.Types.NetworkId (GYNetworkId (..)) type Mnemonic = [T.Text] -- | Opaque type to represent keys of wallet. data WalletKeys = WalletKeys - { wkRootKey :: !(S.Shelley 'RootK XPrv) -- ^ The wallet's root key, aka _master key_. - , wkAcctKey :: !(S.Shelley 'AccountK XPrv) -- ^ The wallet's account key. - , wkPaymentKey :: !(S.Shelley 'PaymentK XPrv) -- ^ The wallet's payment key. - , wkStakeKey :: !(S.Shelley 'DelegationK XPrv) -- ^ The wallet's stake key. + { wkRootKey :: !(S.Shelley 'RootK XPrv) + -- ^ The wallet's root key, aka _master key_. + , wkAcctKey :: !(S.Shelley 'AccountK XPrv) + -- ^ The wallet's account key. + , wkPaymentKey :: !(S.Shelley 'PaymentK XPrv) + -- ^ The wallet's payment key. + , wkStakeKey :: !(S.Shelley 'DelegationK XPrv) + -- ^ The wallet's stake key. } -- | Derives @WalletKeys@ from mnemonic with the given account index and payment address index, thus using derivation path @1852H/1815H/iH/2/0@ for stake key and derivation path @1852H/1815H/iH/0/p@ for payment key where @i@ denotes the account index and @p@ denotes the given payment address index. @@ -58,25 +67,26 @@ walletKeysFromMnemonicIndexed mns nAcctIndex nAddrIndex = let rootK = genMasterKeyFromMnemonic mw mempty :: S.Shelley 'RootK XPrv accIx = indexFromWord32 $ minHardenedPathValue + nAcctIndex addrIx = indexFromWord32 nAddrIndex - - in deriveWalletKeys rootK accIx addrIx - - where - deriveWalletKeys :: S.Shelley 'RootK XPrv -- ^ The Root Key - -> Maybe (Index 'Hardened 'AccountK) -- ^ The Index for Account - -> Maybe (Index 'Soft 'PaymentK) -- ^ The Index for Address - -> Either String WalletKeys - deriveWalletKeys _ Nothing _ = Left $ "Invalid Account Index: " <> show nAcctIndex - deriveWalletKeys _ _ Nothing = Left $ "Invalid Address Index: " <> show nAddrIndex - deriveWalletKeys rootK (Just accIx) (Just addIx) = - let acctK = deriveAccountPrivateKey rootK accIx - paymentK = deriveAddressPrivateKey acctK S.UTxOExternal addIx - stakeK = S.deriveDelegationPrivateKey acctK - - in Right WalletKeys {wkRootKey = rootK, wkAcctKey = acctK, wkPaymentKey = paymentK, wkStakeKey = stakeK} - - -- value for '0H' index - minHardenedPathValue = 0x80000000 + in deriveWalletKeys rootK accIx addrIx + where + deriveWalletKeys :: + S.Shelley 'RootK XPrv -> + -- \^ The Root Key + Maybe (Index 'Hardened 'AccountK) -> + -- \^ The Index for Account + Maybe (Index 'Soft 'PaymentK) -> + -- \^ The Index for Address + Either String WalletKeys + deriveWalletKeys _ Nothing _ = Left $ "Invalid Account Index: " <> show nAcctIndex + deriveWalletKeys _ _ Nothing = Left $ "Invalid Address Index: " <> show nAddrIndex + deriveWalletKeys rootK (Just accIx) (Just addIx) = + let acctK = deriveAccountPrivateKey rootK accIx + paymentK = deriveAddressPrivateKey acctK S.UTxOExternal addIx + stakeK = S.deriveDelegationPrivateKey acctK + in Right WalletKeys {wkRootKey = rootK, wkAcctKey = acctK, wkPaymentKey = paymentK, wkStakeKey = stakeK} + + -- value for '0H' index + minHardenedPathValue = 0x80000000 -- | Derives @WalletKeys@ from mnemonic with first account index, using derivation path @1852H/1815H/0H/2/0@ for stake key and derivation path @1852H/1815H/0H/0/0@ for payment key. walletKeysFromMnemonic :: Mnemonic -> Either String WalletKeys @@ -87,12 +97,13 @@ walletKeysFromMnemonicWithAccIndex :: Mnemonic -> Word32 -> Either String Wallet walletKeysFromMnemonicWithAccIndex ms accIx = walletKeysFromMnemonicIndexed ms accIx 0 walletKeysToExtendedPaymentSigningKey :: WalletKeys -> GYExtendedPaymentSigningKey -walletKeysToExtendedPaymentSigningKey WalletKeys{wkPaymentKey} = S.getKey wkPaymentKey & PaymentExtendedSigningKey & extendedPaymentSigningKeyFromApi +walletKeysToExtendedPaymentSigningKey WalletKeys {wkPaymentKey} = S.getKey wkPaymentKey & PaymentExtendedSigningKey & extendedPaymentSigningKeyFromApi walletKeysToExtendedStakeSigningKey :: WalletKeys -> GYExtendedStakeSigningKey -walletKeysToExtendedStakeSigningKey WalletKeys{wkStakeKey} = S.getKey wkStakeKey & StakeExtendedSigningKey & extendedStakeSigningKeyFromApi +walletKeysToExtendedStakeSigningKey WalletKeys {wkStakeKey} = S.getKey wkStakeKey & StakeExtendedSigningKey & extendedStakeSigningKeyFromApi {-# DEPRECATED writeExtendedPaymentSigningKeyTextEnvelope "Use combination of walletKeysFromMnemonic, walletKeysToExtendedPaymentSigningKey and writeExtendedPaymentSigningKey." #-} + -- | Writes @TextEnvelope@ with type @PaymentExtendedSigningKeyShelley_ed25519_bip32@ from mnemonic. writeExtendedPaymentSigningKeyTextEnvelope :: Mnemonic -> FilePath -> IO () writeExtendedPaymentSigningKeyTextEnvelope mnemonic fPath = do @@ -101,6 +112,7 @@ writeExtendedPaymentSigningKeyTextEnvelope mnemonic fPath = do Right wk -> walletKeysToExtendedPaymentSigningKey wk & writeExtendedPaymentSigningKey fPath {-# DEPRECATED writeStakeSigningKeyTextEnvelope "Use combination of walletKeysFromMnemonic, walletKeysToExtendedStakeSigningKey and writeExtendedStakeSigningKey." #-} + -- | Writes @TextEnvelope@ with type @StakeExtendedSigningKeyShelley_ed25519_bip32@ from mnemonic. writeStakeSigningKeyTextEnvelope :: Mnemonic -> FilePath -> IO () writeStakeSigningKeyTextEnvelope mnemonic fPath = do @@ -110,14 +122,14 @@ writeStakeSigningKeyTextEnvelope mnemonic fPath = do -- | Gives the delegation address made using extended payment and stake keys. walletKeysToAddress :: WalletKeys -> GYNetworkId -> GYAddress -walletKeysToAddress WalletKeys{wkPaymentKey, wkStakeKey} netId = +walletKeysToAddress WalletKeys {wkPaymentKey, wkStakeKey} netId = let paymentCredential = S.PaymentFromExtendedKey $ toXPub <$> wkPaymentKey delegationCredential = S.DelegationFromExtendedKey $ toXPub <$> wkStakeKey - in S.delegationAddress netId' paymentCredential delegationCredential & bech32 & unsafeAddressFromText + in S.delegationAddress netId' paymentCredential delegationCredential & bech32 & unsafeAddressFromText where netId' = case netId of - GYMainnet -> S.shelleyMainnet + GYMainnet -> S.shelleyMainnet GYTestnetPreprod -> S.shelleyTestnet GYTestnetPreview -> S.shelleyTestnet - GYTestnetLegacy -> S.shelleyTestnet - GYPrivnet{} -> S.shelleyTestnet + GYTestnetLegacy -> S.shelleyTestnet + GYPrivnet {} -> S.shelleyTestnet diff --git a/src/GeniusYield/Utils.hs b/src/GeniusYield/Utils.hs index 776dbd46..2a0649a0 100644 --- a/src/GeniusYield/Utils.hs +++ b/src/GeniusYield/Utils.hs @@ -1,25 +1,24 @@ -{-| +{- | Module : GeniusYield.Utils Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} -module GeniusYield.Utils - ( fieldNamePrefixStrip2 - , fieldNamePrefixStrip3 - , fieldNamePrefixStrip4 - , fieldNamePrefixStripN - , modifyException - , serialiseToBech32WithPrefix - ) where - -import Cardano.Api (SerialiseAsRawBytes (serialiseToRawBytes)) -import Codec.Binary.Bech32 as Bech32 -import Control.Monad.Except (ExceptT (..)) -import Data.Char (toLower) -import GeniusYield.Imports +module GeniusYield.Utils ( + fieldNamePrefixStrip2, + fieldNamePrefixStrip3, + fieldNamePrefixStrip4, + fieldNamePrefixStripN, + modifyException, + serialiseToBech32WithPrefix, +) where + +import Cardano.Api (SerialiseAsRawBytes (serialiseToRawBytes)) +import Codec.Binary.Bech32 as Bech32 +import Control.Monad.Except (ExceptT (..)) +import Data.Char (toLower) +import GeniusYield.Imports -- | @fieldNamePrefixStrip2 "muAssets" == "assets"@ fieldNamePrefixStrip2 :: String -> String @@ -38,13 +37,16 @@ fieldNamePrefixStripN :: Int -> String -> String fieldNamePrefixStripN n fldName = case drop n fldName of x : xs -> toLower x : xs; [] -> [] -- | Map the exception type in an 'ExceptT' with a function. -modifyException :: Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a +modifyException :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a modifyException f (ExceptT meith) = ExceptT $ first f <$> meith -serialiseToBech32WithPrefix :: SerialiseAsRawBytes a => Text -> a -> Text +serialiseToBech32WithPrefix :: (SerialiseAsRawBytes a) => Text -> a -> Text serialiseToBech32WithPrefix prefix = case Bech32.humanReadablePartFromText prefix of - Left e -> error $ "serialiseToBech32WithPrefix: invalid prefix " - ++ show prefix - ++ ", " ++ show e + Left e -> + error $ + "serialiseToBech32WithPrefix: invalid prefix " + ++ show prefix + ++ ", " + ++ show e Right p -> serialiseToRawBytes >>> Bech32.dataPartFromBytes >>> Bech32.encodeLenient p diff --git a/tests-privnet/GeniusYield/Test/Privnet/SimpleScripts.hs b/tests-privnet/GeniusYield/Test/Privnet/SimpleScripts.hs index 480128c1..bae2ff43 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/SimpleScripts.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/SimpleScripts.hs @@ -2,22 +2,24 @@ module GeniusYield.Test.Privnet.SimpleScripts ( simpleScriptsTests, ) where -import Control.Lens (each, (%~), (&)) -import Control.Monad (when) -import GeniusYield.Test.Privnet.Ctx -import GeniusYield.Test.Privnet.Setup -import GeniusYield.TxBuilder -import GeniusYield.Types -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCaseSteps) +import Control.Lens (each, (%~), (&)) +import Control.Monad (when) +import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Setup +import GeniusYield.TxBuilder +import GeniusYield.Types +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps) simpleScriptsTests :: Setup -> TestTree -simpleScriptsTests setup = testGroup "simple-scripts" - [ testCaseSteps "exercising a multi-sig simple script without giving it as reference" $ \info -> withSetup info setup $ \ctx -> do - exerciseASimpleScript ctx info False - , testCaseSteps "exercising a multi-sig simple script when given as a reference" $ \info -> withSetup info setup $ \ctx -> do - exerciseASimpleScript ctx info True - ] +simpleScriptsTests setup = + testGroup + "simple-scripts" + [ testCaseSteps "exercising a multi-sig simple script without giving it as reference" $ \info -> withSetup info setup $ \ctx -> do + exerciseASimpleScript ctx info False + , testCaseSteps "exercising a multi-sig simple script when given as a reference" $ \info -> withSetup info setup $ \ctx -> do + exerciseASimpleScript ctx info True + ] exerciseASimpleScript :: Ctx -> (String -> IO ()) -> Bool -> IO () exerciseASimpleScript ctx info toUseRefScript = do diff --git a/tests-privnet/GeniusYield/Test/Privnet/Stake.hs b/tests-privnet/GeniusYield/Test/Privnet/Stake.hs index 673cedc6..52d6121a 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Stake.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Stake.hs @@ -3,5 +3,5 @@ module GeniusYield.Test.Privnet.Stake ( stakeValidatorTests, ) where -import GeniusYield.Test.Privnet.Stake.Key (stakeKeyTests) -import GeniusYield.Test.Privnet.Stake.Validator (stakeValidatorTests) +import GeniusYield.Test.Privnet.Stake.Key (stakeKeyTests) +import GeniusYield.Test.Privnet.Stake.Validator (stakeValidatorTests) diff --git a/tests-privnet/GeniusYield/Test/Privnet/Stake/Key.hs b/tests-privnet/GeniusYield/Test/Privnet/Stake/Key.hs index 1dd35e2b..ecedca5c 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Stake/Key.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Stake/Key.hs @@ -1,14 +1,16 @@ module GeniusYield.Test.Privnet.Stake.Key ( - stakeKeyTests, + stakeKeyTests, ) where -import GeniusYield.Test.Privnet.Setup -import GeniusYield.Test.Privnet.Stake.Utils -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCaseSteps) +import GeniusYield.Test.Privnet.Setup +import GeniusYield.Test.Privnet.Stake.Utils +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps) stakeKeyTests :: Setup -> TestTree -stakeKeyTests setup = testGroup "stake" - [ testCaseSteps "exercising stake credential registration, delegation, rewards claiming & de-registration via stake key" $ \info -> withSetup info setup $ \ctx -> do - stakeIntegrationTest Nothing info ctx - ] +stakeKeyTests setup = + testGroup + "stake" + [ testCaseSteps "exercising stake credential registration, delegation, rewards claiming & de-registration via stake key" $ \info -> withSetup info setup $ \ctx -> do + stakeIntegrationTest Nothing info ctx + ] diff --git a/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs b/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs index f5692dac..e1bb54ef 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs @@ -11,26 +11,28 @@ module GeniusYield.Test.Privnet.Stake.Utils ( stakeIntegrationTest, ) where -import Data.Foldable (for_) -import Data.Maybe (fromJust, - isNothing) -import qualified Data.Set as Set -import GeniusYield.Imports -import GeniusYield.OnChain.AStakeValidator.Compiled (originalAStakeValidator) -import GeniusYield.Test.Privnet.Ctx -import GeniusYield.Transaction (GYCoinSelectionStrategy (..)) -import GeniusYield.TxBuilder -import GeniusYield.Types -import GeniusYield.Types.Delegatee (GYDelegatee (..)) -import Test.Tasty.HUnit (assertBool) +import Data.Foldable (for_) +import Data.Maybe ( + fromJust, + isNothing, + ) +import Data.Set qualified as Set +import GeniusYield.Imports +import GeniusYield.OnChain.AStakeValidator.Compiled (originalAStakeValidator) +import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Transaction (GYCoinSelectionStrategy (..)) +import GeniusYield.TxBuilder +import GeniusYield.Types +import GeniusYield.Types.Delegatee (GYDelegatee (..)) +import Test.Tasty.HUnit (assertBool) someAddr :: GYAddress someAddr = unsafeAddressFromText "addr_test1wpgexmeunzsykesf42d4eqet5yvzeap6trjnflxqtkcf66g0kpnxt" aStakeValidator :: GYStakeValidator 'PlutusV2 aStakeValidator = - stakeValidatorFromPlutus @'PlutusV2 - $ originalAStakeValidator (addressToPlutus someAddr) + stakeValidatorFromPlutus @'PlutusV2 $ + originalAStakeValidator (addressToPlutus someAddr) createMangledUser :: Ctx -> GYStakeCredential -> IO User createMangledUser ctx stakeCred = do @@ -66,15 +68,16 @@ resolveWdrlWitness isScript = if not isScript then GYTxWdrlWitnessKey else GYTxW registerStakeCredentialSteps :: GYCoinSelectionStrategy -> User -> Maybe GYStakeValidatorHash -> (String -> IO ()) -> Ctx -> IO () registerStakeCredentialSteps strat user mstakeValHash info ctx = do mstakeAddressInfo <- ctxRunQuery ctx $ stakeAddressInfo (resolveStakeAddress (ctxNetworkId ctx) user mstakeValHash) - if isJust mstakeAddressInfo then do - info "Stake credential already registered\n" - else do - pp <- ctxGetParams ctx & gyGetProtocolParameters' - info $ "-- Protocol parameters --\n" <> show pp <> "\n-- x --\n" - txBodyReg <- ctxRun ctx user $ do - buildTxBodyWithStrategy strat $ mustHaveCertificate (mkStakeAddressRegistrationCertificate (resolveStakeCredential user mstakeValHash) (resolveCertWitness (isJust mstakeValHash))) - info $ "-- Registration tx body --\n" <> show txBodyReg <> "\n-- x --\n" - ctxRun ctx user $ submitTxBodyConfirmed_ txBodyReg $ resolveSigningRequirement user mstakeValHash + if isJust mstakeAddressInfo + then do + info "Stake credential already registered\n" + else do + pp <- ctxGetParams ctx & gyGetProtocolParameters' + info $ "-- Protocol parameters --\n" <> show pp <> "\n-- x --\n" + txBodyReg <- ctxRun ctx user $ do + buildTxBodyWithStrategy strat $ mustHaveCertificate (mkStakeAddressRegistrationCertificate (resolveStakeCredential user mstakeValHash) (resolveCertWitness (isJust mstakeValHash))) + info $ "-- Registration tx body --\n" <> show txBodyReg <> "\n-- x --\n" + ctxRun ctx user $ submitTxBodyConfirmed_ txBodyReg $ resolveSigningRequirement user mstakeValHash delegateStakeCredentialSteps :: GYCoinSelectionStrategy -> User -> Maybe GYStakeValidatorHash -> GYStakePoolId -> (String -> IO ()) -> Ctx -> IO () delegateStakeCredentialSteps strat user mstakeValHash spId info ctx = do @@ -93,9 +96,10 @@ deregisterStakeCredentialSteps strat user mstakeValHash info ctx = do withdrawRewardsSteps :: GYCoinSelectionStrategy -> User -> Maybe GYStakeValidatorHash -> Natural -> (String -> IO ()) -> Ctx -> IO () withdrawRewardsSteps strat user mstakeValHash rewards info ctx = do txBodyWithdraw <- ctxRun ctx user $ do - buildTxBodyWithStrategy strat $ mustHaveWithdrawal (GYTxWdrl (resolveStakeAddress (ctxNetworkId ctx) user mstakeValHash) rewards (resolveWdrlWitness (isJust mstakeValHash))) <> case mstakeValHash of - Just _ -> mustHaveOutput (mkGYTxOutNoDatum someAddr mempty) - Nothing -> mempty + buildTxBodyWithStrategy strat $ + mustHaveWithdrawal (GYTxWdrl (resolveStakeAddress (ctxNetworkId ctx) user mstakeValHash) rewards (resolveWdrlWitness (isJust mstakeValHash))) <> case mstakeValHash of + Just _ -> mustHaveOutput (mkGYTxOutNoDatum someAddr mempty) + Nothing -> mempty info $ "-- Withdrawal tx body --\n" <> show txBodyWithdraw <> "\n-- x --\n" ctxRun ctx user . submitTxBodyConfirmed_ txBodyWithdraw $ resolveSigningRequirement user mstakeValHash diff --git a/tests-privnet/GeniusYield/Test/Privnet/Stake/Validator.hs b/tests-privnet/GeniusYield/Test/Privnet/Stake/Validator.hs index 72669acb..803bab37 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Stake/Validator.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Stake/Validator.hs @@ -2,17 +2,19 @@ module GeniusYield.Test.Privnet.Stake.Validator ( stakeValidatorTests, ) where -import GeniusYield.Test.Privnet.Setup -import GeniusYield.Test.Privnet.Stake.Utils -import GeniusYield.Types -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCaseSteps) +import GeniusYield.Test.Privnet.Setup +import GeniusYield.Test.Privnet.Stake.Utils +import GeniusYield.Types +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps) aStakeValidatorHash :: GYStakeValidatorHash aStakeValidatorHash = stakeValidatorHash aStakeValidator stakeValidatorTests :: Setup -> TestTree -stakeValidatorTests setup = testGroup "stake" - [ testCaseSteps "exercising stake credential registration, delegation, rewards claiming & de-registration via stake validator" $ \info -> withSetup info setup $ \ctx -> do - stakeIntegrationTest (Just aStakeValidatorHash) info ctx - ] +stakeValidatorTests setup = + testGroup + "stake" + [ testCaseSteps "exercising stake credential registration, delegation, rewards claiming & de-registration via stake validator" $ \info -> withSetup info setup $ \ctx -> do + stakeIntegrationTest (Just aStakeValidatorHash) info ctx + ] diff --git a/tests-privnet/atlas-privnet-tests.hs b/tests-privnet/atlas-privnet-tests.hs index 0622dacf..97316b7d 100644 --- a/tests-privnet/atlas-privnet-tests.hs +++ b/tests-privnet/atlas-privnet-tests.hs @@ -1,69 +1,65 @@ -{-| +{- | Module : Main Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop - -} module Main (main) where -import GeniusYield.Imports +import GeniusYield.Imports -import Test.Tasty (defaultMain, testGroup) -import Test.Tasty.HUnit (testCaseSteps) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (testCaseSteps) -import GeniusYield.CardanoApi.EraHistory -import GeniusYield.Types +import GeniusYield.CardanoApi.EraHistory +import GeniusYield.Types -import GeniusYield.Test.Privnet.Ctx -import qualified GeniusYield.Test.Privnet.Examples -import GeniusYield.Test.Privnet.Setup -import qualified GeniusYield.Test.Privnet.SimpleScripts -import qualified GeniusYield.Test.Privnet.Stake -import GeniusYield.TxBuilder +import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Examples qualified +import GeniusYield.Test.Privnet.Setup +import GeniusYield.Test.Privnet.SimpleScripts qualified +import GeniusYield.Test.Privnet.Stake qualified +import GeniusYield.TxBuilder main :: IO () main = do - withPrivnet cardanoDefaultTestnetOptionsConway $ \setup -> - defaultMain $ testGroup "atlas-privnet-tests" - [ testCaseSteps "Balances" $ \info -> withSetup info setup $ \ctx -> do - forM_ (zip [(1 :: Integer) ..] (ctxUserF ctx : ctxUsers ctx)) - (\(i, ctxUser) -> do + withPrivnet cardanoDefaultTestnetOptionsConway $ \setup -> + defaultMain $ + testGroup + "atlas-privnet-tests" + [ testCaseSteps "Balances" $ \info -> withSetup info setup $ \ctx -> do + forM_ + (zip [(1 :: Integer) ..] (ctxUserF ctx : ctxUsers ctx)) + ( \(i, ctxUser) -> do userIutxos <- gyQueryUtxosAtAddress (ctxProviders ctx) (userAddr ctxUser) Nothing - info $ unlines $ - printf "User%s:" (if i == 1 then "F" else show i) : - [ printf "%s: %s" (utxoRef utxo) (utxoValue utxo) - | utxo <- utxosToList userIutxos - ] - - ) - , testCaseSteps "SlotConfig" $ \info -> withSetup info setup $ \ctx -> do - slot <- ctxSlotOfCurrentBlock ctx - info $ printf "Slot %s" slot - - sc <- ctxSlotConfig ctx - info $ show sc - - , testCaseSteps "GetParameters" $ \info -> withSetup info setup $ \ctx -> do - ss <- ctxRunQuery ctx systemStart - info $ printf "System start: %s" (show ss) - - sp <- ctxRunQuery ctx stakePools - info $ printf "Stake pools: %s" (show sp) - - eh <- ctxRunQuery ctx eraHistory - info $ showEraSummaries eh - - pp <- ctxRunQuery ctx protocolParams - info $ printf "Protocol parameters: %s" (show pp) - - , GeniusYield.Test.Privnet.Examples.tests setup - - , GeniusYield.Test.Privnet.Stake.stakeKeyTests setup - , GeniusYield.Test.Privnet.Stake.stakeValidatorTests setup - - , GeniusYield.Test.Privnet.SimpleScripts.simpleScriptsTests setup - - ] - + info $ + unlines $ + printf "User%s:" (if i == 1 then "F" else show i) + : [ printf "%s: %s" (utxoRef utxo) (utxoValue utxo) + | utxo <- utxosToList userIutxos + ] + ) + , testCaseSteps "SlotConfig" $ \info -> withSetup info setup $ \ctx -> do + slot <- ctxSlotOfCurrentBlock ctx + info $ printf "Slot %s" slot + + sc <- ctxSlotConfig ctx + info $ show sc + , testCaseSteps "GetParameters" $ \info -> withSetup info setup $ \ctx -> do + ss <- ctxRunQuery ctx systemStart + info $ printf "System start: %s" (show ss) + + sp <- ctxRunQuery ctx stakePools + info $ printf "Stake pools: %s" (show sp) + + eh <- ctxRunQuery ctx eraHistory + info $ showEraSummaries eh + + pp <- ctxRunQuery ctx protocolParams + info $ printf "Protocol parameters: %s" (show pp) + , GeniusYield.Test.Privnet.Examples.tests setup + , GeniusYield.Test.Privnet.Stake.stakeKeyTests setup + , GeniusYield.Test.Privnet.Stake.stakeValidatorTests setup + , GeniusYield.Test.Privnet.SimpleScripts.simpleScriptsTests setup + ] diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs index 57ca703c..3ccc2d36 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs @@ -1,15 +1,15 @@ -module GeniusYield.Test.Unified.BetRef.Operations - ( betRefValidator' - , betRefAddress - , placeBet - , takeBets - ) where +module GeniusYield.Test.Unified.BetRef.Operations ( + betRefValidator', + betRefAddress, + placeBet, + takeBets, +) where -import GeniusYield.Imports -import GeniusYield.TxBuilder -import GeniusYield.Types +import GeniusYield.Imports +import GeniusYield.TxBuilder +import GeniusYield.Types -import GeniusYield.Test.Unified.OnChain.BetRef.Compiled +import GeniusYield.Test.Unified.OnChain.BetRef.Compiled -- | Validator in question, obtained after giving required parameters. betRefValidator' :: BetRefParams -> GYValidator 'PlutusV2 @@ -20,14 +20,21 @@ betRefAddress :: (HasCallStack, GYTxQueryMonad m) => BetRefParams -> m GYAddress betRefAddress brp = scriptAddress $ betRefValidator' brp -- | Operation to place bet. -placeBet :: (HasCallStack, GYTxQueryMonad m) - => GYTxOutRef -- ^ Reference Script. - -> BetRefParams -- ^ Validator Params. - -> OracleAnswerDatum -- ^ Guess. - -> GYValue -- ^ Bet amount to place. - -> GYAddress -- ^ Own address. - -> Maybe GYTxOutRef -- ^ Reference to previous bets UTxO (if any). - -> m (GYTxSkeleton 'PlutusV2) +placeBet :: + (HasCallStack, GYTxQueryMonad m) => + -- | Reference Script. + GYTxOutRef -> + -- | Validator Params. + BetRefParams -> + -- | Guess. + OracleAnswerDatum -> + -- | Bet amount to place. + GYValue -> + -- | Own address. + GYAddress -> + -- | Reference to previous bets UTxO (if any). + Maybe GYTxOutRef -> + m (GYTxSkeleton 'PlutusV2) placeBet refScript brp guess bet ownAddr mPreviousBetsUtxoRef = do gyLogDebug' "" $ printf "ownAddr: %s" (show ownAddr) gyLogDebug' "" $ printf "refOut: %s" (show mPreviousBetsUtxoRef) @@ -37,12 +44,14 @@ placeBet refScript brp guess bet ownAddr mPreviousBetsUtxoRef = do case mPreviousBetsUtxoRef of -- This is the first bet. Nothing -> do - return $ mustHaveOutput $ GYTxOut - { gyTxOutAddress = betAddr - , gyTxOutValue = bet - , gyTxOutDatum = Just (datumFromPlutusData $ BetRefDatum [(pubKeyHashToPlutus pkh, guess)] (valueToPlutus bet), GYTxOutDontUseInlineDatum) - , gyTxOutRefS = Nothing - } + return $ + mustHaveOutput $ + GYTxOut + { gyTxOutAddress = betAddr + , gyTxOutValue = bet + , gyTxOutDatum = Just (datumFromPlutusData $ BetRefDatum [(pubKeyHashToPlutus pkh, guess)] (valueToPlutus bet), GYTxOutDontUseInlineDatum) + , gyTxOutRefS = Nothing + } -- Need to append to previous. Just previousBetsUtxoRef -> do previousUtxo <- utxoAtTxOutRef' previousBetsUtxoRef @@ -52,46 +61,56 @@ placeBet refScript brp guess bet ownAddr mPreviousBetsUtxoRef = do betUntilSlot <- enclosingSlotFromTime' (timeFromPlutus $ brpBetUntil brp) gyLogDebug' "" $ printf "3. bet until slot %s" (show betUntilSlot) return $ - input brp refScript previousBetsUtxoRef dat (Bet guess) - <> mustHaveOutput GYTxOut + input brp refScript previousBetsUtxoRef dat (Bet guess) + <> mustHaveOutput + GYTxOut { gyTxOutAddress = betAddr , gyTxOutValue = bet <> previousValue - , gyTxOutDatum = Just - ( datumFromPlutusData $ BetRefDatum ((pubKeyHashToPlutus pkh, guess) : previousGuesses) (valueToPlutus bet) - , GYTxOutDontUseInlineDatum - ) - , gyTxOutRefS = Nothing + , gyTxOutDatum = + Just + ( datumFromPlutusData $ BetRefDatum ((pubKeyHashToPlutus pkh, guess) : previousGuesses) (valueToPlutus bet) + , GYTxOutDontUseInlineDatum + ) + , gyTxOutRefS = Nothing } - <> isInvalidAfter betUntilSlot - <> mustBeSignedBy pkh + <> isInvalidAfter betUntilSlot + <> mustBeSignedBy pkh -- | Operation to take UTxO corresponding to previous bets. -takeBets :: (HasCallStack, GYTxUserQueryMonad m) - => GYTxOutRef -- ^ Reference Script. - -> BetRefParams -- ^ Validator params. - -> GYTxOutRef -- ^ Script UTxO to consume. - -> GYAddress -- ^ Own address. - -> GYTxOutRef -- ^ Oracle reference input. - -> m (GYTxSkeleton 'PlutusV2) +takeBets :: + (HasCallStack, GYTxUserQueryMonad m) => + -- | Reference Script. + GYTxOutRef -> + -- | Validator params. + BetRefParams -> + -- | Script UTxO to consume. + GYTxOutRef -> + -- | Own address. + GYAddress -> + -- | Oracle reference input. + GYTxOutRef -> + m (GYTxSkeleton 'PlutusV2) takeBets refScript brp previousBetsUtxoRef ownAddr oracleRefInput = do pkh <- addressToPubKeyHash' ownAddr previousUtxo <- utxoAtTxOutRef' previousBetsUtxoRef (_addr, _previousValue, dat) <- utxoDatum' previousUtxo betRevealSlot <- enclosingSlotFromTime' (timeFromPlutus $ brpBetReveal brp) return $ - input brp refScript previousBetsUtxoRef dat Take - <> isInvalidBefore betRevealSlot - <> mustHaveRefInput oracleRefInput - <> mustBeSignedBy pkh + input brp refScript previousBetsUtxoRef dat Take + <> isInvalidBefore betRevealSlot + <> mustHaveRefInput oracleRefInput + <> mustBeSignedBy pkh -- | Utility function to consume script UTxO. input :: BetRefParams -> GYTxOutRef -> GYTxOutRef -> BetRefDatum -> BetRefAction -> GYTxSkeleton 'PlutusV2 input brp refScript inputRef dat red = - mustHaveInput GYTxIn - { gyTxInTxOutRef = inputRef - -- , gyTxInWitness = GYTxInWitnessKey - , gyTxInWitness = GYTxInWitnessScript - (GYInReference refScript $ validatorToScript $ betRefValidator' brp) - (datumFromPlutusData dat) - (redeemerFromPlutusData red) - } + mustHaveInput + GYTxIn + { gyTxInTxOutRef = inputRef + , -- , gyTxInWitness = GYTxInWitnessKey + gyTxInWitness = + GYTxInWitnessScript + (GYInReference refScript $ validatorToScript $ betRefValidator' brp) + (datumFromPlutusData dat) + (redeemerFromPlutusData red) + } diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index 3bc6d3a3..1ac09db1 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -1,30 +1,33 @@ -module GeniusYield.Test.Unified.BetRef.PlaceBet - ( placeBetTests - , computeParamsAndAddRefScript - , multipleBetsTraceCore - ) where +module GeniusYield.Test.Unified.BetRef.PlaceBet ( + placeBetTests, + computeParamsAndAddRefScript, + multipleBetsTraceCore, +) where -import Control.Monad.Except (handleError) -import qualified Data.Set as Set -import qualified Data.Text as T -import Test.Tasty (TestTree, - testGroup) +import Control.Monad.Except (handleError) +import Data.Set qualified as Set +import Data.Text qualified as T +import Test.Tasty ( + TestTree, + testGroup, + ) +import GeniusYield.Test.Unified.BetRef.Operations +import GeniusYield.Test.Unified.OnChain.BetRef.Compiled -import GeniusYield.Test.Unified.BetRef.Operations -import GeniusYield.Test.Unified.OnChain.BetRef.Compiled - -import GeniusYield.HTTP.Errors -import GeniusYield.Imports -import GeniusYield.Test.Clb -import GeniusYield.Test.Privnet.Setup -import GeniusYield.Test.Utils -import GeniusYield.TxBuilder -import GeniusYield.Types +import GeniusYield.HTTP.Errors +import GeniusYield.Imports +import GeniusYield.Test.Clb +import GeniusYield.Test.Privnet.Setup +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types -- | Our unit tests for placing bet operation placeBetTests :: Setup -> TestTree -placeBetTests setup = testGroup "Place Bet" +placeBetTests setup = + testGroup + "Place Bet" [ mkTestFor "Simple spending tx" $ simplSpendingTxTrace . testWallets , mkPrivnetTestFor_ "Simple spending tx - privnet" $ simplSpendingTxTrace . testWallets , mkTestFor "Balance checks after placing first bet" firstBetTest @@ -34,45 +37,54 @@ placeBetTests setup = testGroup "Place Bet" , mkTestFor "Not adding atleast bet step amount should fail" $ mustFail . failingMultipleBetsTest , mkPrivnetTestFor' "Not adding atleast bet step amount should fail - privnet" GYDebug setup $ handleError - (\case + ( \case GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () e -> throwError e ) - . failingMultipleBetsTest + . failingMultipleBetsTest ] where mkPrivnetTestFor_ = flip mkPrivnetTestFor setup - firstBetTest :: GYTxGameMonad m => TestInfo -> m () + firstBetTest :: (GYTxGameMonad m) => TestInfo -> m () firstBetTest = firstBetTrace (OracleAnswerDatum 3) (valueFromLovelace 20_000_000) . testWallets - multipleBetsTest :: GYTxGameMonad m => TestInfo -> m () - multipleBetsTest TestInfo{..} = multipleBetsTraceWrapper 400 1_000 (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) - ] - testWallets - failingMultipleBetsTest :: GYTxGameMonad m => TestInfo -> m () - failingMultipleBetsTest TestInfo{..} = multipleBetsTraceWrapper 400 1_000 (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 55_000_000 <> valueSingleton testGoldAsset 1_000) - ] - testWallets + multipleBetsTest :: (GYTxGameMonad m) => TestInfo -> m () + multipleBetsTest TestInfo {..} = + multipleBetsTraceWrapper + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + testWallets + failingMultipleBetsTest :: (GYTxGameMonad m) => TestInfo -> m () + failingMultipleBetsTest TestInfo {..} = + multipleBetsTraceWrapper + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 55_000_000 <> valueSingleton testGoldAsset 1_000) + ] + testWallets -- ----------------------------------------------------------------------------- -- Super-trivial example -- ----------------------------------------------------------------------------- -- | Trace for a super-simple spending transaction. -simplSpendingTxTrace :: GYTxGameMonad m => Wallets -> m () -simplSpendingTxTrace Wallets{w1} = do +simplSpendingTxTrace :: (GYTxGameMonad m) => Wallets -> m () +simplSpendingTxTrace Wallets {w1} = do gyLogDebug' "" "Hey there!" -- balance assetion check - withWalletBalancesCheckSimple [w1 := valueFromLovelace (-100_000_000)] . asUser w1 $ do -- TODO: w1 is the wallets that gets all funds for now + withWalletBalancesCheckSimple [w1 := valueFromLovelace (-100_000_000)] . asUser w1 $ do + -- TODO: w1 is the wallets that gets all funds for now skeleton <- mkTrivialTx gyLogDebug' "" $ printf "tx skeleton: %s" (show skeleton) @@ -81,7 +93,7 @@ simplSpendingTxTrace Wallets{w1} = do gyLogDebug' "" $ printf "tx submitted, txId: %s" txId -- Pretend off-chain code written in 'GYTxUserQueryMonad m' -mkTrivialTx :: GYTxUserQueryMonad m => m (GYTxSkeleton 'PlutusV2) +mkTrivialTx :: (GYTxUserQueryMonad m) => m (GYTxSkeleton 'PlutusV2) mkTrivialTx = do addr <- ownChangeAddress gyLogDebug' "" $ printf "ownAddr: %s" (show addr) @@ -90,12 +102,13 @@ mkTrivialTx = do -- let targetAddr = unsafeAddressFromText "addr1q82vfntpz92f9pawk8gs0fdmhtfe32pqcx0s8fuztxaw3p5pjay24kygaj4g8uevf89ewxzvsdc60wln8spzm2al059qytcwae" return $ mustHaveOutput - (GYTxOut - { gyTxOutAddress = targetAddr - , gyTxOutValue = valueFromLovelace 100_000_000 - , gyTxOutDatum = Nothing - , gyTxOutRefS = Nothing - }) + ( GYTxOut + { gyTxOutAddress = targetAddr + , gyTxOutValue = valueFromLovelace 100_000_000 + , gyTxOutDatum = Nothing + , gyTxOutRefS = Nothing + } + ) <> mustBeSignedBy pkh {- @@ -113,40 +126,50 @@ Level 3. The action (Off-chain code) -- ----------------------------------------------------------------------------- -- | Trace for placing the first bet. -firstBetTrace :: GYTxGameMonad m - => OracleAnswerDatum -- ^ Guess - -> GYValue -- ^ Bet - -> Wallets -> m () -- Our continuation function -firstBetTrace dat bet ws@Wallets{w1} = do +firstBetTrace :: + (GYTxGameMonad m) => + -- | Guess + OracleAnswerDatum -> + -- | Bet + GYValue -> + Wallets -> + m () -- Our continuation function +firstBetTrace dat bet ws@Wallets {w1} = do currSlot <- slotToInteger <$> slotOfCurrentBlock let betUntil = currSlot + 40 betReveal = currSlot + 100 -- First step: Get the required parameters for initializing our parameterized script, -- claculate the script, and post it to the blockchain as a reference script. (brp, refScript) <- computeParamsAndAddRefScript betUntil betReveal (valueFromLovelace 200_000_000) ws - withWalletBalancesCheckSimple [w1 := valueNegate bet] . asUser w1 $ do -- following operations are ran by first wallet, `w1` + withWalletBalancesCheckSimple [w1 := valueNegate bet] . asUser w1 $ do + -- following operations are ran by first wallet, `w1` -- Second step: Perform the actual run. void $ placeBetRun refScript brp dat bet Nothing -- | Function to compute the parameters for the contract and add the corresponding refernce script. -computeParamsAndAddRefScript - :: GYTxGameMonad m - => Integer -- ^ Bet Until slot - -> Integer -- ^ Bet Reveal slot - -> GYValue -- ^ Bet step value - -> Wallets -> m (BetRefParams, GYTxOutRef) -- Our continuation -computeParamsAndAddRefScript betUntil' betReveal' betStep Wallets{..} = do +computeParamsAndAddRefScript :: + (GYTxGameMonad m) => + -- | Bet Until slot + Integer -> + -- | Bet Reveal slot + Integer -> + -- | Bet step value + GYValue -> + Wallets -> + m (BetRefParams, GYTxOutRef) -- Our continuation +computeParamsAndAddRefScript betUntil' betReveal' betStep Wallets {..} = do let betUntil = slotFromApi (fromInteger betUntil') betReveal = slotFromApi (fromInteger betReveal') asUser w1 $ do betUntilTime <- slotToBeginTime betUntil betRevealTime <- slotToBeginTime betReveal - let brp = BetRefParams - (pubKeyHashToPlutus $ userPkh w8) -- let oracle be wallet `w8` - (timeToPlutus betUntilTime) - (timeToPlutus betRevealTime) - (valueToPlutus betStep) + let brp = + BetRefParams + (pubKeyHashToPlutus $ userPkh w8) -- let oracle be wallet `w8` + (timeToPlutus betUntilTime) + (timeToPlutus betRevealTime) + (valueToPlutus betStep) -- let store scripts in `w9` let w9addr = userAddr w9 @@ -156,29 +179,35 @@ computeParamsAndAddRefScript betUntil' betReveal' betStep Wallets{..} = do pure (brp, refScript) -- | Run to call the `placeBet` operation. -placeBetRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> OracleAnswerDatum -> GYValue -> Maybe GYTxOutRef -> m GYTxId +placeBetRun :: (GYTxMonad m) => GYTxOutRef -> BetRefParams -> OracleAnswerDatum -> GYValue -> Maybe GYTxOutRef -> m GYTxId placeBetRun refScript brp guess bet mPreviousBetsUtxoRef = do addr <- ownChangeAddress gyLogDebug' "" $ printf "bet: %s" (show bet) skeleton <- placeBet refScript brp guess bet addr mPreviousBetsUtxoRef gyLogDebug' "" $ printf "place bet tx skeleton: %s" (show skeleton) buildTxBody skeleton >>= signAndSubmitConfirmed - -- txId <- sendSkeleton skeleton - -- dumpUtxoState - -- pure txId + +-- txId <- sendSkeleton skeleton +-- dumpUtxoState +-- pure txId -- ----------------------------------------------------------------------------- -- Multiple bets example -- ----------------------------------------------------------------------------- -- | Trace which allows for multiple bets. -multipleBetsTraceWrapper - :: GYTxGameMonad m - => Integer -- ^ slot for betUntil - -> Integer -- ^ slot for betReveal - -> GYValue -- ^ bet step - -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets - -> Wallets -> m () -- Our continuation function +multipleBetsTraceWrapper :: + (GYTxGameMonad m) => + -- | slot for betUntil + Integer -> + -- | slot for betReveal + Integer -> + -- | bet step + GYValue -> + -- | List denoting the bets + [(Wallets -> User, OracleAnswerDatum, GYValue)] -> + Wallets -> + m () -- Our continuation function multipleBetsTraceWrapper betUntil' betReveal' betStep walletBets ws = do currSlot <- slotToInteger <$> slotOfCurrentBlock let betUntil = currSlot + betUntil' @@ -189,18 +218,22 @@ multipleBetsTraceWrapper betUntil' betReveal' betStep walletBets ws = do multipleBetsTraceCore brp refScript walletBets ws -- | Trace which allows for multiple bets. -multipleBetsTraceCore - :: GYTxGameMonad m - => BetRefParams - -> GYTxOutRef -- ^ Reference script - -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets - -> Wallets -> m () -- Our continuation function -multipleBetsTraceCore brp refScript walletBets ws@Wallets{..} = do +multipleBetsTraceCore :: + (GYTxGameMonad m) => + BetRefParams -> + -- | Reference script + GYTxOutRef -> + -- | List denoting the bets + [(Wallets -> User, OracleAnswerDatum, GYValue)] -> + Wallets -> + m () -- Our continuation function +multipleBetsTraceCore brp refScript walletBets ws@Wallets {..} = do let - -- | Perform the actual bet operation by the corresponding wallet. - performBetOperations [] _ = return () - performBetOperations ((getWallet, dat, bet) : remWalletBets) isFirst = do - if isFirst then do + -- \| Perform the actual bet operation by the corresponding wallet. + performBetOperations [] _ = return () + performBetOperations ((getWallet, dat, bet) : remWalletBets) isFirst = do + if isFirst + then do gyLogInfo' "" "placing the first bet" asUser (getWallet ws) $ do void $ placeBetRun refScript brp dat bet Nothing @@ -215,32 +248,32 @@ multipleBetsTraceCore brp refScript walletBets ws@Wallets{..} = do void $ placeBetRun refScript brp dat bet (Just utxoRef) performBetOperations remWalletBets False - -- | To sum the bet amount for the corresponding wallet. - sumWalletBets _wallet [] acc = acc - sumWalletBets wallet ((getWallet, _dat, bet) : remWalletBets) acc = sumWalletBets wallet remWalletBets (if getWallet ws == wallet then acc <> valueNegate bet else acc) - -- | Idea here is that for each wallet, we want to know how much has been bet. If we encounter a new wallet, i.e., wallet for whose we haven't yet computed value lost, we call `sumWalletBets` on it. + -- \| To sum the bet amount for the corresponding wallet. + sumWalletBets _wallet [] acc = acc + sumWalletBets wallet ((getWallet, _dat, bet) : remWalletBets) acc = sumWalletBets wallet remWalletBets (if getWallet ws == wallet then acc <> valueNegate bet else acc) + -- \| Idea here is that for each wallet, we want to know how much has been bet. If we encounter a new wallet, i.e., wallet for whose we haven't yet computed value lost, we call `sumWalletBets` on it. - getBalanceDiff [] _set acc = acc - getBalanceDiff wlBets@((getWallet, _dat, _bet) : remWalletBets) set acc = - let wallet = getWallet ws - wallet'sAddr = userAddr wallet - in - if Set.member wallet'sAddr set then getBalanceDiff remWalletBets set acc - else - getBalanceDiff remWalletBets (Set.insert wallet'sAddr set) ((wallet := sumWalletBets wallet wlBets mempty) : acc) + getBalanceDiff [] _set acc = acc + getBalanceDiff wlBets@((getWallet, _dat, _bet) : remWalletBets) set acc = + let wallet = getWallet ws + wallet'sAddr = userAddr wallet + in if Set.member wallet'sAddr set + then getBalanceDiff remWalletBets set acc + else + getBalanceDiff remWalletBets (Set.insert wallet'sAddr set) ((wallet := sumWalletBets wallet wlBets mempty) : acc) - balanceDiffWithoutFees = getBalanceDiff walletBets Set.empty [] + balanceDiffWithoutFees = getBalanceDiff walletBets Set.empty [] -- The test itself balanceBeforeAllTheseOps <- asUser w1 $ traverse (\(wallet, _value) -> queryBalances $ userAddresses' wallet) balanceDiffWithoutFees gyLogDebug' "" $ printf "balanceBeforeAllTheseOps: %s" (mconcat balanceBeforeAllTheseOps) performBetOperations walletBets True - balanceAfterAllTheseOps <- asUser w1 $ traverse (\(wallet, _value) -> queryBalances $ userAddresses' wallet) balanceDiffWithoutFees + balanceAfterAllTheseOps <- asUser w1 $ traverse (\(wallet, _value) -> queryBalances $ userAddresses' wallet) balanceDiffWithoutFees gyLogDebug' "" $ printf "balanceAfterAllTheseOps: %s" (mconcat balanceAfterAllTheseOps) -- Check the difference asUser w1 $ verify (zip3 balanceDiffWithoutFees balanceBeforeAllTheseOps balanceAfterAllTheseOps) where - -- | Function to verify that the wallet indeed lost by /roughly/ the bet amount. + -- \| Function to verify that the wallet indeed lost by /roughly/ the bet amount. -- We say /roughly/ as fees is assumed to be within (0, 1.5 ada]. -- Suppose that wallet x places bet 3 times, where for simplicity assume each tx costed 0.6 ada as fees then the threshold should be above 1.8 ada. verify [] = return () @@ -248,12 +281,17 @@ multipleBetsTraceCore brp refScript walletBets ws@Wallets{..} = do let vAfterWithoutFees = vBefore <> diff (expectedAdaWithoutFees, expectedOtherAssets) = valueSplitAda vAfterWithoutFees (actualAda, actualOtherAssets) = valueSplitAda vAfter - threshold = 1_500_000 -- 1.5 ada - in - if expectedOtherAssets == actualOtherAssets + threshold = 1_500_000 -- 1.5 ada + in if expectedOtherAssets == actualOtherAssets && actualAda < expectedAdaWithoutFees && expectedAdaWithoutFees - threshold <= actualAda - then verify xs - else - throwAppError . someBackendError . T.pack $ ("For wallet " <> show (userAddr wallet) <> " expected value (without fees) " <> - show vAfterWithoutFees <> " but actual is " <> show vAfter) + then verify xs + else + throwAppError . someBackendError . T.pack $ + ( "For wallet " + <> show (userAddr wallet) + <> " expected value (without fees) " + <> show vAfterWithoutFees + <> " but actual is " + <> show vAfter + ) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs index 41d170ae..140fedbd 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -1,25 +1,29 @@ -module GeniusYield.Test.Unified.BetRef.TakePot - ( takeBetPotTests - ) where +module GeniusYield.Test.Unified.BetRef.TakePot ( + takeBetPotTests, +) where -import Control.Monad.Except (handleError) -import Test.Tasty (TestTree, - testGroup) +import Control.Monad.Except (handleError) +import Test.Tasty ( + TestTree, + testGroup, + ) -import GeniusYield.Test.Unified.BetRef.Operations -import GeniusYield.Test.Unified.BetRef.PlaceBet -import GeniusYield.Test.Unified.OnChain.BetRef.Compiled +import GeniusYield.Test.Unified.BetRef.Operations +import GeniusYield.Test.Unified.BetRef.PlaceBet +import GeniusYield.Test.Unified.OnChain.BetRef.Compiled -import GeniusYield.Imports -import GeniusYield.Test.Clb -import GeniusYield.Test.Privnet.Setup -import GeniusYield.Test.Utils -import GeniusYield.TxBuilder -import GeniusYield.Types +import GeniusYield.Imports +import GeniusYield.Test.Clb +import GeniusYield.Test.Privnet.Setup +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types -- | Our unit tests for taking the bet pot operation takeBetPotTests :: Setup -> TestTree -takeBetPotTests setup = testGroup "Take bet pot" +takeBetPotTests setup = + testGroup + "Take bet pot" [ mkTestFor "Balance check after taking bet pot" takeBetsTest , mkPrivnetTestFor_ "Balance check after taking bet pot - privnet" takeBetsTest , mkTestFor "Must fail if attempt to take is by wrong guesser" $ mustFail . wrongGuesserTakeBetsTest @@ -29,8 +33,11 @@ takeBetPotTests setup = testGroup "Take bet pot" ] where mkPrivnetTestFor_ = flip mkPrivnetTestFor setup - takeBetsTest :: GYTxGameMonad m => TestInfo -> m () - takeBetsTest TestInfo{..} = takeBetsTrace 400 1_000 + takeBetsTest :: (GYTxGameMonad m) => TestInfo -> m () + takeBetsTest TestInfo {..} = + takeBetsTrace + 400 + 1_000 (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) @@ -38,50 +45,72 @@ takeBetPotTests setup = testGroup "Take bet pot" , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) ] - 4 w2 testWallets - wrongGuesserTakeBetsTest :: GYTxGameMonad m => TestInfo -> m () - wrongGuesserTakeBetsTest TestInfo{..} = takeBetsTrace - 400 1_000 (valueFromLovelace 10_000_000) + 4 + w2 + testWallets + wrongGuesserTakeBetsTest :: (GYTxGameMonad m) => TestInfo -> m () + wrongGuesserTakeBetsTest TestInfo {..} = + takeBetsTrace + 400 + 1_000 + (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) ] - 5 w2 testWallets - badUpdatedGuessTakeBetsTest :: GYTxGameMonad m => TestInfo -> m () - badUpdatedGuessTakeBetsTest TestInfo{..} = takeBetsTrace 400 1_000 (valueFromLovelace 10_000_000) + 5 + w2 + testWallets + badUpdatedGuessTakeBetsTest :: (GYTxGameMonad m) => TestInfo -> m () + badUpdatedGuessTakeBetsTest TestInfo {..} = + takeBetsTrace + 400 + 1_000 + (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) ] - 2 w2 testWallets + 2 + w2 + testWallets -- Must fail with script execution error (which is fired in the body error auto balance). - mustFailPrivnet = handleError - (\case + mustFailPrivnet = + handleError + ( \case GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () e -> throwError e ) -- | Run to call the `takeBets` operation. -takeBetsRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId +takeBetsRun :: (GYTxMonad m) => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId takeBetsRun refScript brp toConsume refInput = do addr <- ownChangeAddress skeleton <- takeBets refScript brp toConsume addr refInput buildTxBody skeleton >>= signAndSubmitConfirmed -- | Trace for taking bet pot. -takeBetsTrace :: GYTxGameMonad m - => Integer -- ^ slot for betUntil - -> Integer -- ^ slot for betReveal - -> GYValue -- ^ bet step - -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets - -> Integer -- ^ Actual answer - -> (Wallets -> User) -- ^ Taker - -> Wallets -> m () -- Our continuation function -takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker ws@Wallets{..} = do +takeBetsTrace :: + (GYTxGameMonad m) => + -- | slot for betUntil + Integer -> + -- | slot for betReveal + Integer -> + -- | bet step + GYValue -> + -- | List denoting the bets + [(Wallets -> User, OracleAnswerDatum, GYValue)] -> + -- | Actual answer + Integer -> + -- | Taker + (Wallets -> User) -> + Wallets -> + m () -- Our continuation function +takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker ws@Wallets {..} = do currSlot <- slotToInteger <$> slotOfCurrentBlock let betUntil = currSlot + betUntil' betReveal = currSlot + betReveal' @@ -93,5 +122,7 @@ takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker ws@Wallets betRefAddr <- betRefAddress brp _scriptUtxo@GYUTxO {utxoRef, utxoValue} <- head . utxosToList <$> utxosAtAddress betRefAddr Nothing waitUntilSlot_ $ slotFromApi (fromInteger betReveal) - withWalletBalancesCheckSimple [taker := utxoValue] . asUser taker - . void $ takeBetsRun refScript brp utxoRef refInput + withWalletBalancesCheckSimple [taker := utxoValue] + . asUser taker + . void + $ takeBetsRun refScript brp utxoRef refInput diff --git a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs index 380f57dc..6ad20a1b 100644 --- a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs +++ b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs @@ -1,112 +1,128 @@ -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module GeniusYield.Test.Unified.OnChain.BetRef - ( mkBetRefValidator - , OracleAnswerDatum (..) - , BetRefParams (..) - , BetRefDatum (..) - , BetRefAction (..) - ) where - -import PlutusLedgerApi.V1.Address (toPubKeyHash) -import PlutusLedgerApi.V1.Interval (contains) -import PlutusLedgerApi.V1.Value (geq) -import PlutusLedgerApi.V2 -import PlutusLedgerApi.V2.Contexts (findDatum, findOwnInput, - getContinuingOutputs) -import qualified PlutusTx -import PlutusTx.Prelude as PlutusTx -import Prelude (Show) +module GeniusYield.Test.Unified.OnChain.BetRef ( + mkBetRefValidator, + OracleAnswerDatum (..), + BetRefParams (..), + BetRefDatum (..), + BetRefAction (..), +) where + +import PlutusLedgerApi.V1.Address (toPubKeyHash) +import PlutusLedgerApi.V1.Interval (contains) +import PlutusLedgerApi.V1.Value (geq) +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V2.Contexts ( + findDatum, + findOwnInput, + getContinuingOutputs, + ) +import PlutusTx qualified +import PlutusTx.Prelude as PlutusTx +import Prelude (Show) -- | Goals made my the concerned team. type TeamGoals = Integer -- | Match result given by the oracle. newtype OracleAnswerDatum = OracleAnswerDatum TeamGoals deriving newtype (Eq, Show) + PlutusTx.unstableMakeIsData ''OracleAnswerDatum -- | Our contract is parameterized with this. data BetRefParams = BetRefParams - { brpOraclePkh :: PubKeyHash -- ^ Oracle's payment public key hash. This is needed to assert that UTxO being looked at indeed belongs to the Oracle. - , brpBetUntil :: POSIXTime -- ^ Time until which bets can be placed. - , brpBetReveal :: POSIXTime -- ^ Time at which Oracle will reveal the correct match result. - , brpBetStep :: Value -- ^ Each newly placed bet must be more than previous bet by `brpBetStep` amount. + { brpOraclePkh :: PubKeyHash + -- ^ Oracle's payment public key hash. This is needed to assert that UTxO being looked at indeed belongs to the Oracle. + , brpBetUntil :: POSIXTime + -- ^ Time until which bets can be placed. + , brpBetReveal :: POSIXTime + -- ^ Time at which Oracle will reveal the correct match result. + , brpBetStep :: Value + -- ^ Each newly placed bet must be more than previous bet by `brpBetStep` amount. } + -- PlutusTx.makeLift ''BetRefParams PlutusTx.unstableMakeIsData ''BetRefParams -- | List of guesses by users along with the maximum bet placed yet. A new guess gets /prepended/ to this list. Note that since we are always meant to increment previously placed bet with `brpBetStep`, the newly placed bet would necessarily be maximum (it would be foolish to initialize `brpBetStep` with some negative amounts). data BetRefDatum = BetRefDatum - { brdBets :: [(PubKeyHash, OracleAnswerDatum)] + { brdBets :: [(PubKeyHash, OracleAnswerDatum)] , brdPreviousBet :: Value } + PlutusTx.unstableMakeIsData ''BetRefDatum -- | Redeemer representing choices available to the user. -data BetRefAction = Bet !OracleAnswerDatum -- ^ User makes a guess. - | Take -- ^ User takes the pot. +data BetRefAction + = -- | User makes a guess. + Bet !OracleAnswerDatum + | -- | User takes the pot. + Take + PlutusTx.unstableMakeIsData ''BetRefAction -- Note: The first argument is meant to be data encoded 'BetRefParams'. -- Unable to use the actual type since makeLift doesn't work on it, for whatever reason.... -{-# INLINABLE mkBetRefValidator #-} +{-# INLINEABLE mkBetRefValidator #-} + -- | Untyped wrapper around `mkBetRefValidator'`. mkBetRefValidator :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinData -> () mkBetRefValidator params dat' red' ctx' | mkBetRefValidator' (unsafeFromBuiltinData params) (unsafeFromBuiltinData dat') (unsafeFromBuiltinData red') (unsafeFromBuiltinData ctx') = () - | otherwise = error () + | otherwise = error () + +{-# INLINEABLE mkBetRefValidator' #-} -{-# INLINABLE mkBetRefValidator' #-} -- | Core smart contract logic. Read its description from Atlas guide. mkBetRefValidator' :: BetRefParams -> BetRefDatum -> BetRefAction -> ScriptContext -> Bool mkBetRefValidator' (BetRefParams oraclePkh betUntil betReveal betStep) (BetRefDatum previousGuesses previousBet) brAction ctx = case brAction of - Bet guess -> + Bet guess -> let sOut = case getContinuingOutputs ctx of - [sOut'] -> sOut' + [sOut'] -> sOut' _anyOtherMatch -> traceError "Expected only one continuing output." outValue = txOutValue sOut -- Using the 'maybe' utility here makes validation fail... for some reason... -- Why is PlutusTx still allowed to exist? inValue = case findOwnInput ctx of - Nothing -> traceError "Joever!" - Just x -> txOutValue (txInInfoResolved x) + Nothing -> traceError "Joever!" + Just x -> txOutValue (txInInfoResolved x) -- inValue = txOutValue sIn (guessesOut, betOut) = case outputToDatum sOut of - Nothing -> traceError "Could not resolve for script output datum" + Nothing -> traceError "Could not resolve for script output datum" Just (BetRefDatum guessesOut' betOut') -> (guessesOut', betOut') - in + in traceIfFalse "Must be before `BetUntil` time" - (to betUntil `contains` validRange) && - traceIfFalse - "Guesses update is wrong" - ((signerPkh, guess) : previousGuesses == guessesOut) && - traceIfFalse - "The current bet must be more than the previous bet by atleast `brpBetStep` amount" - (outValue `geq` (inValue <> previousBet <> betStep)) && - traceIfFalse - "Out bet is wrong" + (to betUntil `contains` validRange) + && traceIfFalse + "Guesses update is wrong" + ((signerPkh, guess) : previousGuesses == guessesOut) + && traceIfFalse + "The current bet must be more than the previous bet by atleast `brpBetStep` amount" + (outValue `geq` (inValue <> previousBet <> betStep)) + && traceIfFalse + "Out bet is wrong" (inValue == outValue - betOut) Take -> let -- Note that `find` returns the first match. Since we were always prepending, this is valid. Just guess = find ((== signerPkh) . fst) previousGuesses oracleIn = case filter (isNothing . txOutReferenceScript) (txInInfoResolved <$> txInfoReferenceInputs info) of - [oracleIn'] -> oracleIn' - [] -> traceError "No reference input provided" + [oracleIn'] -> oracleIn' + [] -> traceError "No reference input provided" _anyOtherMatch -> traceError "Expected only one reference input" oracleAnswer = case outputToDatum oracleIn of - Nothing -> traceError "Could not resolve for datum" + Nothing -> traceError "Could not resolve for datum" (Just (OracleAnswerDatum oracleAnswer')) -> oracleAnswer' guessDiff = getGuessDiff $ snd guess getGuessDiff (OracleAnswerDatum g) = abs (oracleAnswer - g) @@ -115,21 +131,20 @@ mkBetRefValidator' (BetRefParams oraclePkh betUntil betReveal betStep) (BetRefDa -- code down below. Which will cause issues with BuiltinByteString also being unwrapped into primitive pointers. -- See: https://github.com/IntersectMBO/plutus/issues/4193 mOracleInPkh = toPubKeyHash (txOutAddress oracleIn) - in + in traceIfFalse "Must be after `RevealTime`" - (from betReveal `contains` validRange) && - traceIfFalse - "Must fully spend Script" - (null (getContinuingOutputs ctx)) && - traceIfFalse - "Reference input must be from Oracle address (wrt Payment part)" - (mOracleInPkh == Just oraclePkh) && - traceIfFalse - "Guess is not closest" + (from betReveal `contains` validRange) + && traceIfFalse + "Must fully spend Script" + (null (getContinuingOutputs ctx)) + && traceIfFalse + "Reference input must be from Oracle address (wrt Payment part)" + (mOracleInPkh == Just oraclePkh) + && traceIfFalse + "Guess is not closest" (all (\pg -> getGuessDiff (snd pg) >= guessDiff) previousGuesses) where - info :: TxInfo info = scriptContextTxInfo ctx @@ -138,13 +153,14 @@ mkBetRefValidator' (BetRefParams oraclePkh betUntil betReveal betStep) (BetRefDa signerPkh :: PubKeyHash signerPkh = case txInfoSignatories info of - [signerPkh'] -> signerPkh' - [] -> traceError "No signatory" + [signerPkh'] -> signerPkh' + [] -> traceError "No signatory" _anyOtherMatch -> traceError "Expected only one signatory" - outputToDatum :: FromData b => TxOut -> Maybe b + outputToDatum :: (FromData b) => TxOut -> Maybe b outputToDatum o = case txOutDatum o of - NoOutputDatum -> Nothing - OutputDatum d -> processDatum d + NoOutputDatum -> Nothing + OutputDatum d -> processDatum d OutputDatumHash dh -> processDatum =<< findDatum dh info - where processDatum = fromBuiltinData . getDatum + where + processDatum = fromBuiltinData . getDatum diff --git a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef/Compiled.hs b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef/Compiled.hs index 24e3d94c..8e9b279e 100644 --- a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef/Compiled.hs +++ b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef/Compiled.hs @@ -1,26 +1,24 @@ -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} -- {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-} - -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module GeniusYield.Test.Unified.OnChain.BetRef.Compiled - ( betRefValidator - , BetRefParams (..) - , OracleAnswerDatum (..) - , BetRefDatum (..) - , BetRefAction (..) - ) where +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} -import qualified PlutusTx -import PlutusCore.Version (plcVersion100) +module GeniusYield.Test.Unified.OnChain.BetRef.Compiled ( + betRefValidator, + BetRefParams (..), + OracleAnswerDatum (..), + BetRefDatum (..), + BetRefAction (..), +) where +import PlutusCore.Version (plcVersion100) +import PlutusTx qualified -import GeniusYield.Test.Unified.OnChain.BetRef +import GeniusYield.Test.Unified.OnChain.BetRef -- Since makeLift doesn't seem to work on BetRefParams. We just convert it to data and apply that instead. betRefValidator :: BetRefParams -> PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -betRefValidator betRefParams = - $$(PlutusTx.compile [|| mkBetRefValidator ||]) +betRefValidator betRefParams = + $$(PlutusTx.compile [||mkBetRefValidator||]) `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 (PlutusTx.toBuiltinData betRefParams) diff --git a/tests-unified/atlas-unified-tests.hs b/tests-unified/atlas-unified-tests.hs index c34e68fc..c01ae0b2 100644 --- a/tests-unified/atlas-unified-tests.hs +++ b/tests-unified/atlas-unified-tests.hs @@ -1,14 +1,16 @@ -module Main - ( main - ) where +module Main ( + main, +) where -import Test.Tasty (defaultMain, - testGroup) +import Test.Tasty ( + defaultMain, + testGroup, + ) -import GeniusYield.Test.Privnet.Setup +import GeniusYield.Test.Privnet.Setup -import GeniusYield.Test.Unified.BetRef.PlaceBet -import GeniusYield.Test.Unified.BetRef.TakePot +import GeniusYield.Test.Unified.BetRef.PlaceBet +import GeniusYield.Test.Unified.BetRef.TakePot main :: IO () main = withPrivnet cardanoDefaultTestnetOptionsConway $ \setup -> diff --git a/tests/GeniusYield/Test/CoinSelection.hs b/tests/GeniusYield/Test/CoinSelection.hs index d1f3cb76..f6d76b21 100644 --- a/tests/GeniusYield/Test/CoinSelection.hs +++ b/tests/GeniusYield/Test/CoinSelection.hs @@ -1,43 +1,44 @@ module GeniusYield.Test.CoinSelection where -import Control.Monad.Random (evalRand, mkStdGen) -import Control.Monad.Trans.Except (runExceptT) -import Data.List (tails, (\\)) +import Control.Monad.Random (evalRand, mkStdGen) +import Control.Monad.Trans.Except (runExceptT) +import Data.List (tails, (\\)) -import Test.QuickCheck -import Test.QuickCheck.Monadic as M -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Monadic as M +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -import GeniusYield.Imports -import GeniusYield.Transaction -import GeniusYield.Transaction.CoinSelection -import GeniusYield.Types +import GeniusYield.Imports +import GeniusYield.Transaction +import GeniusYield.Transaction.CoinSelection +import GeniusYield.Types data CoinSelectionTestParams = CoinSelectionTestParams - { cstpTxExtInps :: [GYValue] - -- ^ Existing inputs in the transaction (not coming from own wallet). - , cstpTxOwnInps :: [GYValue] - -- ^ Existing own wallet inputs in the transaction. - , cstpTxOuts :: [GYValue] - -- ^ Desired tx outputs. - , cstpTxMint :: GYValue - -- ^ Value being minted in the transaction. - , cstpOwnUtxos :: [GYValue] - -- ^ This shouldn't contain the collateral. - } - deriving Show + { cstpTxExtInps :: [GYValue] + -- ^ Existing inputs in the transaction (not coming from own wallet). + , cstpTxOwnInps :: [GYValue] + -- ^ Existing own wallet inputs in the transaction. + , cstpTxOuts :: [GYValue] + -- ^ Desired tx outputs. + , cstpTxMint :: GYValue + -- ^ Value being minted in the transaction. + , cstpOwnUtxos :: [GYValue] + -- ^ This shouldn't contain the collateral. + } + deriving (Show) prettyTestParams :: CoinSelectionTestParams -> String -prettyTestParams CoinSelectionTestParams{..} = unlines - [ "* Params:" - , "\tExtInputs = [\n" ++ (unlines (map (("\t\t" ++) . show) cstpTxExtInps) ++ "\t]") - , "\tOwnInputs = [\n" ++ (unlines (map (("\t\t" ++) . show) cstpTxOwnInps) ++ "\t]") - , "\tTxOuts = [\n" ++ (unlines (map (("\t\t" ++) . show) cstpTxOuts) ++ "\t]") - , "\tTxMint = " ++ show cstpTxMint - , "\tOwnUtxos = [\n" ++ (unlines (map (("\t\t" ++) . show) cstpOwnUtxos) ++ "\t]") - ] +prettyTestParams CoinSelectionTestParams {..} = + unlines + [ "* Params:" + , "\tExtInputs = [\n" ++ (unlines (map (("\t\t" ++) . show) cstpTxExtInps) ++ "\t]") + , "\tOwnInputs = [\n" ++ (unlines (map (("\t\t" ++) . show) cstpTxOwnInps) ++ "\t]") + , "\tTxOuts = [\n" ++ (unlines (map (("\t\t" ++) . show) cstpTxOuts) ++ "\t]") + , "\tTxMint = " ++ show cstpTxMint + , "\tOwnUtxos = [\n" ++ (unlines (map (("\t\t" ++) . show) cstpOwnUtxos) ++ "\t]") + ] -- Constant address used across all coin selection tests, since the address does not affect the logic being tested. mockChangeAddress :: GYAddress @@ -90,186 +91,207 @@ gyToken = GYToken "ff80aaaf03a273b8f5c558168dc0e2377eea810badbae6eceefc14ef" "GY ------------------------------------------------------------------------------- coinSelectionTests :: TestTree -coinSelectionTests = testGroup "CoinSelection" [ testGroup "LargestFirst" largestFirstTests - , testGroup "RandomImprove" randomImproveTests - ] +coinSelectionTests = + testGroup + "CoinSelection" + [ testGroup "LargestFirst" largestFirstTests + , testGroup "RandomImprove" randomImproveTests + ] quickCheckTests :: GYCoinSelectionStrategy -> TestTree -quickCheckTests strat = testGroup "QuickCheck" - [ testProperty "Additional inputs included in own utxos" $ - testCaseQuickCheckBody strat propInputsAreSubset - , testProperty "Inputs can pay outputs" $ - testCaseQuickCheckBody strat propInputsAreEnough - , testProperty "Change is enough" $ - testCaseQuickCheckBody strat propChangeIsEnough - ] +quickCheckTests strat = + testGroup + "QuickCheck" + [ testProperty "Additional inputs included in own utxos" $ + testCaseQuickCheckBody strat propInputsAreSubset + , testProperty "Inputs can pay outputs" $ + testCaseQuickCheckBody strat propInputsAreEnough + , testProperty "Change is enough" $ + testCaseQuickCheckBody strat propChangeIsEnough + ] largestFirstTests :: [TestTree] largestFirstTests = [quickCheckTests GYLargestFirstMultiAsset] randomImproveTests :: [TestTree] randomImproveTests = - [ quickCheckTests GYRandomImproveMultiAsset - , testGroup "Basic" - [ testCase "no extra input needed" $ do - let expectedAdditionalInps = [] - expectedChangeOuts = [valueFromLovelace 5_000_000] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [valueFromLovelace 10_000_000] - , cstpTxOuts = [valueFromLovelace 3_000_000] - , cstpTxMint = mempty - , cstpOwnUtxos = [] - } - , testCase "no output" $ do - let expectedAdditionalInps = [] - expectedChangeOuts = [valueFromLovelace 4_000_000] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [valueFromLovelace 6_000_000] - , cstpTxOuts = [] - , cstpTxMint = mempty - , cstpOwnUtxos = [] - } - , testCase "no output and no change" $ do - let expectedAdditionalInps = [] - expectedChangeOuts = [] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [valueFromLovelace 2_000_000] - , cstpTxOuts = [] - , cstpTxMint = mempty - , cstpOwnUtxos = [] - } - , testCase "no inputs and no mint" $ do - let expectedAdditionalInps = [valueFromLovelace 10_000_000] - expectedChangeOuts = [valueFromLovelace 3_000_000] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [] - , cstpTxOuts = [valueFromLovelace 5_000_000] - , cstpTxMint = mempty - , cstpOwnUtxos = [valueFromLovelace 10_000_000] - } - , testCase "burning all from inputs" $ do - let expectedAdditionalInps = [valueFromLovelace 10_000_000] - expectedChangeOuts = [valueFromLovelace 3_000_000] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [valueFromLovelace 5_000_000 <> valueSingleton (mockAsset "A") 5] - , cstpTxOuts = [valueFromLovelace 10_000_000] - , cstpTxMint = valueSingleton (mockAsset "A") (-5) - , cstpOwnUtxos = [valueFromLovelace 10_000_000] - } - , testCase "burning all from utxos" $ do - let expectedAdditionalInps = [valueFromLovelace 10_000_000 <> valueSingleton (mockAsset "A") 5] - expectedChangeOuts = [valueFromLovelace 10_000_000] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [valueFromLovelace 12_000_000] - , cstpTxOuts = [valueFromLovelace 10_000_000] - , cstpTxMint = valueSingleton (mockAsset "A") (-5) - , cstpOwnUtxos = [valueFromLovelace 10_000_000 <> valueSingleton (mockAsset "A") 5] - } - , testCase "burning some" $ do - let expectedAdditionalInps = [valueFromLovelace 10_000_000] - expectedChangeOuts = [valueFromLovelace 10_000_000 <> valueSingleton (mockAsset "A") 5] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [valueFromLovelace 12_000_000 <> valueSingleton (mockAsset "A") 10] - , cstpTxOuts = [valueFromLovelace 10_000_000] - , cstpTxMint = valueSingleton (mockAsset "A") (-5) - , cstpOwnUtxos = [valueFromLovelace 10_000_000] - } - , testCase "minting to output" $ do - let expectedAdditionalInps = [valueFromLovelace 10_000_000] - expectedChangeOuts = [valueFromLovelace 3_000_000] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [] - , cstpTxOuts = [valueFromLovelace 5_000_000 <> valueSingleton (mockAsset "A") 1] - , cstpTxMint = valueSingleton (mockAsset "A") 1 - , cstpOwnUtxos = [valueFromLovelace 10_000_000] - } - , testCase "minting to change" $ do - let expectedAdditionalInps = [valueFromLovelace 10_000_000] - expectedChangeOuts = [valueFromLovelace 3_000_000 <> valueSingleton (mockAsset "A") 1] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [] - , cstpTxOuts = [valueFromLovelace 5_000_000] - , cstpTxMint = valueSingleton (mockAsset "A") 1 - , cstpOwnUtxos = [valueFromLovelace 10_000_000] - } - , testCase "multiple outputs" $ do - let expectedAdditionalInps = [valueFromLovelace 25_000_000] - expectedChangeOuts = [valueFromLovelace 2_000_000] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [] - , cstpTxOuts = [ valueFromLovelace 5_000_000 - , valueFromLovelace 10_000_000 - , valueFromLovelace 6_000_000 - ] - , cstpTxMint = mempty - , cstpOwnUtxos = [valueFromLovelace 25_000_000] - } - , testCase "multi-asset basic" $ do - let expectedAdditionalInps = [ valueFromLovelace 10_000_000 - , valueFromLovelace 2_000_000 <> valueSingleton (mockAsset "A") 1 - ] - expectedChangeOuts = [valueFromLovelace 7_000_000] - testCaseBody expectedAdditionalInps expectedChangeOuts $ CoinSelectionTestParams - { cstpTxExtInps = [] - , cstpTxOwnInps = [] - , cstpTxOuts = [valueFromLovelace 3_000_000 <> valueSingleton (mockAsset "A") 1] - , cstpTxMint = mempty - , cstpOwnUtxos = [ valueFromLovelace 10_000_000 - , valueFromLovelace 2_000_000 <> valueSingleton (mockAsset "A") 1 - ] - } - ] - , testGroup "TokenSalePlaceOrder" - [ testCase "wallet.zebra" $ do - let expectedAdditionalInps = [valueFromLovelace 5000_000_000] - expectedChangeOuts = [valueFromLovelace 4696_000_000] - testCaseBody expectedAdditionalInps expectedChangeOuts (tokenSalePlaceTestParams 300_000_000 zebra) - , testCase "wallet.whale" $ do - let expectedAdditionalInps = - [ valueFromLovelace 720_834_944 - , valueFromLovelace 29_850_895 - ] - expectedChangeOuts = - [ valueFromLovelace 714_685_839] - testCaseBody expectedAdditionalInps expectedChangeOuts (tokenSalePlaceTestParams 32_000_000 whale) - , testCase "wallet.rideTheWave" $ do - let expectedAdditionalInps = - [ valueFromLovelace 9750_000_000 - , valueFromLovelace 3690_000_000 - , valueFromLovelace 2997_540_000 - , valueFromLovelace 1498_860_000 - , valueFromLovelace 1498_860_000 - , valueFromLovelace 1000_000_000 - , valueFromLovelace 1_480_000 <> valueSingleton (mockAsset "A") 1 - , valueFromLovelace 1_480_000 <> valueSingleton (mockAsset "B") 1 - , valueFromLovelace 1_440_000 <> valueSingleton (mockAsset "C") 1 - , valueFromLovelace 1_440_000 <> valueSingleton (mockAsset "D") 1 - ] - expectedChangeOuts = - [ valueFromLovelace 535_100_000 - <> valueSingleton (mockAsset "A") 1 - <> valueSingleton (mockAsset "B") 1 - <> valueSingleton (mockAsset "C") 1 - <> valueSingleton (mockAsset "D") 1 - ] - testCaseBody expectedAdditionalInps expectedChangeOuts (tokenSalePlaceTestParams 19_902_000_000 rideTheWave) - ] - ] + [ quickCheckTests GYRandomImproveMultiAsset + , testGroup + "Basic" + [ testCase "no extra input needed" $ do + let expectedAdditionalInps = [] + expectedChangeOuts = [valueFromLovelace 5_000_000] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [valueFromLovelace 10_000_000] + , cstpTxOuts = [valueFromLovelace 3_000_000] + , cstpTxMint = mempty + , cstpOwnUtxos = [] + } + , testCase "no output" $ do + let expectedAdditionalInps = [] + expectedChangeOuts = [valueFromLovelace 4_000_000] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [valueFromLovelace 6_000_000] + , cstpTxOuts = [] + , cstpTxMint = mempty + , cstpOwnUtxos = [] + } + , testCase "no output and no change" $ do + let expectedAdditionalInps = [] + expectedChangeOuts = [] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [valueFromLovelace 2_000_000] + , cstpTxOuts = [] + , cstpTxMint = mempty + , cstpOwnUtxos = [] + } + , testCase "no inputs and no mint" $ do + let expectedAdditionalInps = [valueFromLovelace 10_000_000] + expectedChangeOuts = [valueFromLovelace 3_000_000] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [] + , cstpTxOuts = [valueFromLovelace 5_000_000] + , cstpTxMint = mempty + , cstpOwnUtxos = [valueFromLovelace 10_000_000] + } + , testCase "burning all from inputs" $ do + let expectedAdditionalInps = [valueFromLovelace 10_000_000] + expectedChangeOuts = [valueFromLovelace 3_000_000] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [valueFromLovelace 5_000_000 <> valueSingleton (mockAsset "A") 5] + , cstpTxOuts = [valueFromLovelace 10_000_000] + , cstpTxMint = valueSingleton (mockAsset "A") (-5) + , cstpOwnUtxos = [valueFromLovelace 10_000_000] + } + , testCase "burning all from utxos" $ do + let expectedAdditionalInps = [valueFromLovelace 10_000_000 <> valueSingleton (mockAsset "A") 5] + expectedChangeOuts = [valueFromLovelace 10_000_000] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [valueFromLovelace 12_000_000] + , cstpTxOuts = [valueFromLovelace 10_000_000] + , cstpTxMint = valueSingleton (mockAsset "A") (-5) + , cstpOwnUtxos = [valueFromLovelace 10_000_000 <> valueSingleton (mockAsset "A") 5] + } + , testCase "burning some" $ do + let expectedAdditionalInps = [valueFromLovelace 10_000_000] + expectedChangeOuts = [valueFromLovelace 10_000_000 <> valueSingleton (mockAsset "A") 5] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [valueFromLovelace 12_000_000 <> valueSingleton (mockAsset "A") 10] + , cstpTxOuts = [valueFromLovelace 10_000_000] + , cstpTxMint = valueSingleton (mockAsset "A") (-5) + , cstpOwnUtxos = [valueFromLovelace 10_000_000] + } + , testCase "minting to output" $ do + let expectedAdditionalInps = [valueFromLovelace 10_000_000] + expectedChangeOuts = [valueFromLovelace 3_000_000] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [] + , cstpTxOuts = [valueFromLovelace 5_000_000 <> valueSingleton (mockAsset "A") 1] + , cstpTxMint = valueSingleton (mockAsset "A") 1 + , cstpOwnUtxos = [valueFromLovelace 10_000_000] + } + , testCase "minting to change" $ do + let expectedAdditionalInps = [valueFromLovelace 10_000_000] + expectedChangeOuts = [valueFromLovelace 3_000_000 <> valueSingleton (mockAsset "A") 1] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [] + , cstpTxOuts = [valueFromLovelace 5_000_000] + , cstpTxMint = valueSingleton (mockAsset "A") 1 + , cstpOwnUtxos = [valueFromLovelace 10_000_000] + } + , testCase "multiple outputs" $ do + let expectedAdditionalInps = [valueFromLovelace 25_000_000] + expectedChangeOuts = [valueFromLovelace 2_000_000] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [] + , cstpTxOuts = + [ valueFromLovelace 5_000_000 + , valueFromLovelace 10_000_000 + , valueFromLovelace 6_000_000 + ] + , cstpTxMint = mempty + , cstpOwnUtxos = [valueFromLovelace 25_000_000] + } + , testCase "multi-asset basic" $ do + let expectedAdditionalInps = + [ valueFromLovelace 10_000_000 + , valueFromLovelace 2_000_000 <> valueSingleton (mockAsset "A") 1 + ] + expectedChangeOuts = [valueFromLovelace 7_000_000] + testCaseBody expectedAdditionalInps expectedChangeOuts $ + CoinSelectionTestParams + { cstpTxExtInps = [] + , cstpTxOwnInps = [] + , cstpTxOuts = [valueFromLovelace 3_000_000 <> valueSingleton (mockAsset "A") 1] + , cstpTxMint = mempty + , cstpOwnUtxos = + [ valueFromLovelace 10_000_000 + , valueFromLovelace 2_000_000 <> valueSingleton (mockAsset "A") 1 + ] + } + ] + , testGroup + "TokenSalePlaceOrder" + [ testCase "wallet.zebra" $ do + let expectedAdditionalInps = [valueFromLovelace 5000_000_000] + expectedChangeOuts = [valueFromLovelace 4696_000_000] + testCaseBody expectedAdditionalInps expectedChangeOuts (tokenSalePlaceTestParams 300_000_000 zebra) + , testCase "wallet.whale" $ do + let expectedAdditionalInps = + [ valueFromLovelace 720_834_944 + , valueFromLovelace 29_850_895 + ] + expectedChangeOuts = + [valueFromLovelace 714_685_839] + testCaseBody expectedAdditionalInps expectedChangeOuts (tokenSalePlaceTestParams 32_000_000 whale) + , testCase "wallet.rideTheWave" $ do + let expectedAdditionalInps = + [ valueFromLovelace 9750_000_000 + , valueFromLovelace 3690_000_000 + , valueFromLovelace 2997_540_000 + , valueFromLovelace 1498_860_000 + , valueFromLovelace 1498_860_000 + , valueFromLovelace 1000_000_000 + , valueFromLovelace 1_480_000 <> valueSingleton (mockAsset "A") 1 + , valueFromLovelace 1_480_000 <> valueSingleton (mockAsset "B") 1 + , valueFromLovelace 1_440_000 <> valueSingleton (mockAsset "C") 1 + , valueFromLovelace 1_440_000 <> valueSingleton (mockAsset "D") 1 + ] + expectedChangeOuts = + [ valueFromLovelace 535_100_000 + <> valueSingleton (mockAsset "A") 1 + <> valueSingleton (mockAsset "B") 1 + <> valueSingleton (mockAsset "C") 1 + <> valueSingleton (mockAsset "D") 1 + ] + testCaseBody expectedAdditionalInps expectedChangeOuts (tokenSalePlaceTestParams 19_902_000_000 rideTheWave) + ] + ] where testCaseBody expectedAdditionalInps expectedChangeOuts params = do - case runCoinSelectionTest GYRandomImproveMultiAsset params of - Left err -> assertFailure $ "Selection failed: " ++ show err - Right x -> (expectedAdditionalInps, expectedChangeOuts) @=? x + case runCoinSelectionTest GYRandomImproveMultiAsset params of + Left err -> assertFailure $ "Selection failed: " ++ show err + Right x -> (expectedAdditionalInps, expectedChangeOuts) @=? x ------------------------------------------------------------------------------- -- Transaction representing place token sale order @@ -279,17 +301,18 @@ randomImproveTests = (for some amount of tokens at some price), and the wallet distribution. -} tokenSalePlaceTestParams :: Natural -> [GYValue] -> CoinSelectionTestParams -tokenSalePlaceTestParams payment wallet = CoinSelectionTestParams +tokenSalePlaceTestParams payment wallet = + CoinSelectionTestParams { cstpTxExtInps = [] , cstpTxOwnInps = [] - , cstpTxOuts = [valueInsert GYLovelace lovelaceAmount gyTokenVal <> valueFromLovelace (fromIntegral payment)] - , cstpTxMint = gyTokenVal - , cstpOwnUtxos = wallet + , cstpTxOuts = [valueInsert GYLovelace lovelaceAmount gyTokenVal <> valueFromLovelace (fromIntegral payment)] + , cstpTxMint = gyTokenVal + , cstpOwnUtxos = wallet } where lovelaceAmount = max minLovelace $ valueAssetClass gyTokenVal GYLovelace - minLovelace = toInteger $ mockMinimumUtxo gyTokenVal - gyTokenVal = valueSingleton gyToken 1 + minLovelace = toInteger $ mockMinimumUtxo gyTokenVal + gyTokenVal = valueSingleton gyToken 1 ------------------------------------------------------------------------------- -- Different mock wallet distributions @@ -305,62 +328,62 @@ This represents a basic/typical preprod wallet. -} zebra :: [GYValue] zebra = - [ valueFromLovelace 5000_000_000 - , valueFromLovelace 3_000_000 - <> valueSingleton (mockAsset "A") 1 - <> valueSingleton (mockAsset "B") 1 - <> valueSingleton (mockAsset "C") 1 - <> valueSingleton (mockAsset "D") 1 - <> valueSingleton (mockAsset "E") 1 - <> valueSingleton (mockAsset "F") 1 - , valueFromLovelace 2_000_000 - ] + [ valueFromLovelace 5000_000_000 + , valueFromLovelace 3_000_000 + <> valueSingleton (mockAsset "A") 1 + <> valueSingleton (mockAsset "B") 1 + <> valueSingleton (mockAsset "C") 1 + <> valueSingleton (mockAsset "D") 1 + <> valueSingleton (mockAsset "E") 1 + <> valueSingleton (mockAsset "F") 1 + , valueFromLovelace 2_000_000 + ] -- Skimmed representation of a randomly picked mainnet wallet. whale :: [GYValue] whale = - [ valueFromLovelace 1_202_490 <> valueSingleton (mockAsset "X") 1 - , valueFromLovelace 720_834_944 - , valueFromLovelace 8_238_547 - <> valueSingleton (mockAsset "A") 1 - <> valueSingleton (mockAsset "B") 1 - <> valueSingleton (mockAsset "C") 1 - <> valueSingleton (mockAsset "D") 1 - <> valueSingleton (mockAsset "E") 1 - <> valueSingleton (mockAsset "F") 150_951_806 - <> valueSingleton (mockAsset "G") 58 - <> valueSingleton (mockAsset "H") 1 - <> valueSingleton (mockAsset "I") 1 - , valueFromLovelace 4_620_320 - <> valueSingleton (mockAsset "Ax") 1_166 - <> valueSingleton (mockAsset "Bx") 1 - <> valueSingleton (mockAsset "Cx") 990_000_000 - <> valueSingleton (mockAsset "Dx") 1_464_223 - <> valueSingleton (mockAsset "Ex") 1 - <> valueSingleton (mockAsset "Fx") 1 - <> valueSingleton (mockAsset "Gx") 1 - <> valueSingleton (mockAsset "Hx") 122_000_000 - <> valueSingleton (mockAsset "Ix") 24_403_870 - <> valueSingleton (mockAsset "Jx") 1 - <> valueSingleton (mockAsset "Kx") 1 - , valueFromLovelace 5_000_000 - , valueFromLovelace 29_850_895 - ] + [ valueFromLovelace 1_202_490 <> valueSingleton (mockAsset "X") 1 + , valueFromLovelace 720_834_944 + , valueFromLovelace 8_238_547 + <> valueSingleton (mockAsset "A") 1 + <> valueSingleton (mockAsset "B") 1 + <> valueSingleton (mockAsset "C") 1 + <> valueSingleton (mockAsset "D") 1 + <> valueSingleton (mockAsset "E") 1 + <> valueSingleton (mockAsset "F") 150_951_806 + <> valueSingleton (mockAsset "G") 58 + <> valueSingleton (mockAsset "H") 1 + <> valueSingleton (mockAsset "I") 1 + , valueFromLovelace 4_620_320 + <> valueSingleton (mockAsset "Ax") 1_166 + <> valueSingleton (mockAsset "Bx") 1 + <> valueSingleton (mockAsset "Cx") 990_000_000 + <> valueSingleton (mockAsset "Dx") 1_464_223 + <> valueSingleton (mockAsset "Ex") 1 + <> valueSingleton (mockAsset "Fx") 1 + <> valueSingleton (mockAsset "Gx") 1 + <> valueSingleton (mockAsset "Hx") 122_000_000 + <> valueSingleton (mockAsset "Ix") 24_403_870 + <> valueSingleton (mockAsset "Jx") 1 + <> valueSingleton (mockAsset "Kx") 1 + , valueFromLovelace 5_000_000 + , valueFromLovelace 29_850_895 + ] -- | https://cexplorer.io/tx/c2fb472634f2cbb9f1d38db44e8beca1d10acdf91b4c8b943c858e0302b5a240 rideTheWave :: [GYValue] rideTheWave = - [ valueFromLovelace 9750_000_000 - , valueFromLovelace 3690_000_000 - , valueFromLovelace 2997_540_000 - , valueFromLovelace 1498_860_000 - , valueFromLovelace 1498_860_000 - , valueFromLovelace 1000_000_000 - , valueFromLovelace 1_480_000 <> valueSingleton (mockAsset "A") 1 - , valueFromLovelace 1_480_000 <> valueSingleton (mockAsset "B") 1 - , valueFromLovelace 1_440_000 <> valueSingleton (mockAsset "C") 1 - , valueFromLovelace 1_440_000 <> valueSingleton (mockAsset "D") 1 - ] + [ valueFromLovelace 9750_000_000 + , valueFromLovelace 3690_000_000 + , valueFromLovelace 2997_540_000 + , valueFromLovelace 1498_860_000 + , valueFromLovelace 1498_860_000 + , valueFromLovelace 1000_000_000 + , valueFromLovelace 1_480_000 <> valueSingleton (mockAsset "A") 1 + , valueFromLovelace 1_480_000 <> valueSingleton (mockAsset "B") 1 + , valueFromLovelace 1_440_000 <> valueSingleton (mockAsset "C") 1 + , valueFromLovelace 1_440_000 <> valueSingleton (mockAsset "D") 1 + ] ------------------------------------------------------------------------------- -- Utilities @@ -373,38 +396,41 @@ is a list of change outputs generated. -} runCoinSelectionTest :: GYCoinSelectionStrategy -> CoinSelectionTestParams -> Either GYBalancingError ([GYValue], [GYValue]) runCoinSelectionTest cstrat cstParams = do - (additionalInps, changeOuts) <- (`evalRand` pureStdGen) - . runExceptT $ selectInputs (coinSelectionTestParamsToEnv cstParams) cstrat - let inpVals = gyTxInDetValue <$> additionalInps - changeVals = gyTxOutValue <$> changeOuts - pure (inpVals, changeVals) + (additionalInps, changeOuts) <- + (`evalRand` pureStdGen) + . runExceptT + $ selectInputs (coinSelectionTestParamsToEnv cstParams) cstrat + let inpVals = gyTxInDetValue <$> additionalInps + changeVals = gyTxOutValue <$> changeOuts + pure (inpVals, changeVals) where -- We use a pure StdGen for reproducible tests. pureStdGen = mkStdGen 936 -- 42 wasn't random enough. coinSelectionTestParamsToEnv :: CoinSelectionTestParams -> GYCoinSelectionEnv v coinSelectionTestParamsToEnv CoinSelectionTestParams {cstpTxExtInps, cstpTxOwnInps, cstpTxOuts, cstpTxMint, cstpOwnUtxos} = - buildEnvWith - ownUtxos - inps - -- TODO: Should we use different recipient addresses for each output? #36 - -- (https://github.com/geniusyield/atlas/issues/36) - ((mockRecipientAddress, ) <$> cstpTxOuts) - cstpTxMint + buildEnvWith + ownUtxos + inps + -- TODO: Should we use different recipient addresses for each output? #36 + -- (https://github.com/geniusyield/atlas/issues/36) + ((mockRecipientAddress,) <$> cstpTxOuts) + cstpTxMint where ownUtxos = buildOwnUtxos cstpOwnUtxos - inps = buildInps cstpTxExtInps cstpTxOwnInps + inps = buildInps cstpTxExtInps cstpTxOwnInps buildEnvWith :: GYUTxOs -> [GYTxInDetailed v] -> [(GYAddress, GYValue)] -> GYValue -> GYCoinSelectionEnv v -buildEnvWith ownUtxos existingInps targetOuts mintVal = GYCoinSelectionEnv - { existingInputs = existingInps +buildEnvWith ownUtxos existingInps targetOuts mintVal = + GYCoinSelectionEnv + { existingInputs = existingInps , requiredOutputs = targetOuts - , mintValue = mintVal - , changeAddr = mockChangeAddress - , ownUtxos = ownUtxos - , extraLovelace = mockExtraLovelace - , minimumUTxOF = mockMinimumUtxo . gyTxOutValue - , maxValueSize = 5000 -- Current max value size (obtained from protocol params) + , mintValue = mintVal + , changeAddr = mockChangeAddress + , ownUtxos = ownUtxos + , extraLovelace = mockExtraLovelace + , minimumUTxOF = mockMinimumUtxo . gyTxOutValue + , maxValueSize = 5000 -- Current max value size (obtained from protocol params) , adaSource = 0 , adaSink = 0 } @@ -412,26 +438,31 @@ buildEnvWith ownUtxos existingInps targetOuts mintVal = GYCoinSelectionEnv buildInps :: [GYValue] -> [GYValue] -> [GYTxInDetailed v] buildInps ext own = go (ext ++ own) where - go = zipWith - (\i v -> GYTxInDetailed - (GYTxIn (txOutRefFromTuple (mockTxId1, i)) GYTxInWitnessKey) - mockInpAddress - v - GYOutDatumNone - Nothing + go = + zipWith + ( \i v -> + GYTxInDetailed + (GYTxIn (txOutRefFromTuple (mockTxId1, i)) GYTxInWitnessKey) + mockInpAddress + v + GYOutDatumNone + Nothing ) - [0..] + [0 ..] buildOwnUtxos :: [GYValue] -> GYUTxOs -buildOwnUtxos = utxosFromList . zipWith - (\i v -> GYUTxO - (txOutRefFromTuple (mockTxId2, i)) - mockChangeAddress - v - GYOutDatumNone - Nothing - ) - [0..] +buildOwnUtxos = + utxosFromList + . zipWith + ( \i v -> + GYUTxO + (txOutRefFromTuple (mockTxId2, i)) + mockChangeAddress + v + GYOutDatumNone + Nothing + ) + [0 ..] ------------------------------------------------------------------------------- -- QuickCheck Props @@ -462,32 +493,36 @@ buildOwnUtxos = utxosFromList . zipWith params as we can't predict the amount of change outputs. -} -testCaseQuickCheckBody - :: GYCoinSelectionStrategy - -> (GYCoinSelectionEnv v -> [GYTxInDetailed v] -> [GYTxOut v] -> Bool) - -> Property +testCaseQuickCheckBody :: + GYCoinSelectionStrategy -> + (GYCoinSelectionEnv v -> [GYTxInDetailed v] -> [GYTxOut v] -> Bool) -> + Property testCaseQuickCheckBody strat prop = forAllShrinkShow genParamsLovelace shrinkParamsLovelace prettyParamsLovelace $ - \(cstParams, extraLov) -> monadicIO $ do - let cstEnv = (coinSelectionTestParamsToEnv cstParams) { extraLovelace = extraLov } - pre $ paramsInputsAreValid extraLov cstParams - pre $ outputsHaveLovelace cstEnv - seed <- run $ generate arbitrary - case (`evalRand` mkStdGen seed) . runExceptT $ selectInputs cstEnv strat of - Left (GYBalancingErrorChangeShortFall _) -> discard - Left err -> fail $ show err - Right (addInputs, changeOuts) -> monitor (counterexample (getReason addInputs changeOuts)) >> - M.assert (prop cstEnv addInputs changeOuts) + \(cstParams, extraLov) -> monadicIO $ do + let cstEnv = (coinSelectionTestParamsToEnv cstParams) {extraLovelace = extraLov} + pre $ paramsInputsAreValid extraLov cstParams + pre $ outputsHaveLovelace cstEnv + seed <- run $ generate arbitrary + case (`evalRand` mkStdGen seed) . runExceptT $ selectInputs cstEnv strat of + Left (GYBalancingErrorChangeShortFall _) -> discard + Left err -> fail $ show err + Right (addInputs, changeOuts) -> + monitor (counterexample (getReason addInputs changeOuts)) + >> M.assert (prop cstEnv addInputs changeOuts) where - getReason addInputs changeOuts = unlines [ "* AdditionalInputs: " ++ show addInputs - , "* ChangeOuts: " ++ show changeOuts] - outputsHaveLovelace env = all (\(_,v) -> valueAssetClass v GYLovelace > 0) (requiredOutputs env) + getReason addInputs changeOuts = + unlines + [ "* AdditionalInputs: " ++ show addInputs + , "* ChangeOuts: " ++ show changeOuts + ] + outputsHaveLovelace env = all (\(_, v) -> valueAssetClass v GYLovelace > 0) (requiredOutputs env) propInputsAreSubset :: GYCoinSelectionEnv v -> [GYTxInDetailed v] -> [GYTxOut v] -> Bool propInputsAreSubset env addIns _ = all ((`elem` utxosRefs (ownUtxos env)) . gyTxInTxOutRef . gyTxInDet) addIns propInputsAreEnough :: GYCoinSelectionEnv v -> [GYTxInDetailed v] -> [GYTxOut v] -> Bool propInputsAreEnough env addIns _ = - allInputsValue `valueGreaterOrEqual` allOutputsValue + allInputsValue `valueGreaterOrEqual` allOutputsValue where allInputsValue = sumEntries (existingInputs env ++ addIns) <> mintValue env allOutputsValue = mconcat $ map snd (requiredOutputs env) @@ -514,18 +549,19 @@ propChangeIsEnough env addIns changeOuts = changeAssets == txAssets -} genCoinSelectionParams :: Natural -> Gen CoinSelectionTestParams genCoinSelectionParams extraLovelace = do - outs <- listOf genGYValue - (extIns, ownIns, ownUtxos, minted) <- genValidInputs outs - return CoinSelectionTestParams - { cstpTxExtInps = extIns - , cstpTxOwnInps = ownIns - , cstpTxOuts = outs - , cstpTxMint = minted - , cstpOwnUtxos = ownUtxos - } + outs <- listOf genGYValue + (extIns, ownIns, ownUtxos, minted) <- genValidInputs outs + return + CoinSelectionTestParams + { cstpTxExtInps = extIns + , cstpTxOwnInps = ownIns + , cstpTxOuts = outs + , cstpTxMint = minted + , cstpOwnUtxos = ownUtxos + } where genGYAssetClass :: Gen GYAssetClass - genGYAssetClass = elements $ map mockAsset ["A","B","C","D","E","F","G","H","I"] + genGYAssetClass = elements $ map mockAsset ["A", "B", "C", "D", "E", "F", "G", "H", "I"] genGYValue :: Gen GYValue genGYValue = oneof [genLovelaceValue, genSingleAssetValue, genAssetValue] @@ -535,39 +571,40 @@ genCoinSelectionParams extraLovelace = do genSingleAssetValue :: Gen GYValue genSingleAssetValue = do - lovelaceVal <- genLovelaceValue - assetClass <- genGYAssetClass - amount <- chooseInteger (1, 10_000) - return (lovelaceVal <> valueSingleton assetClass amount) + lovelaceVal <- genLovelaceValue + assetClass <- genGYAssetClass + amount <- chooseInteger (1, 10_000) + return (lovelaceVal <> valueSingleton assetClass amount) genAssetValue :: Gen GYValue genAssetValue = do - lovelaceVal <- genLovelaceValue - assetClasses <- listOf1 genGYAssetClass - amounts <- vectorOf (length assetClasses) $ chooseInteger (1, 10_000) - return $ lovelaceVal <> valueFromList (zip assetClasses amounts) + lovelaceVal <- genLovelaceValue + assetClasses <- listOf1 genGYAssetClass + amounts <- vectorOf (length assetClasses) $ chooseInteger (1, 10_000) + return $ lovelaceVal <> valueFromList (zip assetClasses amounts) genInputs :: Gen ([GYValue], [GYValue], [GYValue], GYValue) genInputs = do - extIns <- listOf genGYValue - ownIns <- listOf genGYValue - ownUtxos <- listOf genGYValue - minted <- frequency [(3, genAssetValue), (1, return mempty)] - let assetsMinted = snd $ valueSplitAda minted - return (extIns, ownIns, ownUtxos, assetsMinted) + extIns <- listOf genGYValue + ownIns <- listOf genGYValue + ownUtxos <- listOf genGYValue + minted <- frequency [(3, genAssetValue), (1, return mempty)] + let assetsMinted = snd $ valueSplitAda minted + return (extIns, ownIns, ownUtxos, assetsMinted) genValidInputs :: [GYValue] -> Gen ([GYValue], [GYValue], [GYValue], GYValue) genValidInputs outs = genInputs `suchThat` inputsAreValid outs extraLovelace genParamsLovelace :: Gen (CoinSelectionTestParams, Natural) genParamsLovelace = do - el <- elements extraLovelaceValues - params <- genCoinSelectionParams el - return (params, el) + el <- elements extraLovelaceValues + params <- genCoinSelectionParams el + return (params, el) shrinkParamsLovelace :: (CoinSelectionTestParams, Natural) -> [(CoinSelectionTestParams, Natural)] -shrinkParamsLovelace (params, el) = [(nParams, el) | nParams <- shrinkParams params] - ++ [(params, nEl) | nEl <- shrinkExtraLovelace el] +shrinkParamsLovelace (params, el) = + [(nParams, el) | nParams <- shrinkParams params] + ++ [(params, nEl) | nEl <- shrinkExtraLovelace el] ------------------------------------------------------------------------------- -- QuickCheck Shrinks @@ -585,30 +622,22 @@ shrinkParamsLovelace (params, el) = [(nParams, el) | nParams <- shrinkParams par efficient order tested. -} shrinkParams :: CoinSelectionTestParams -> [CoinSelectionTestParams] -shrinkParams params@CoinSelectionTestParams{..} = - [ params { cstpTxOuts = nOuts } | nOuts <- shrinkValues cstpTxOuts] - ++ - [ params { cstpTxMint = nMint } | nMint <- shrinkValue cstpTxMint] - ++ - [ params { cstpTxExtInps = nExtInps } | nExtInps <- shrinkValues cstpTxExtInps] - ++ - [ params { cstpTxOwnInps = nOwnInps } | nOwnInps <- shrinkValues cstpTxOwnInps] - ++ - [ params { cstpOwnUtxos = nOwnUtxos } | nOwnUtxos <- shrinkValues cstpOwnUtxos] - ++ - [ params { cstpTxOuts = nOuts } | nOuts <- collapseValues cstpTxOuts] - ++ - [ params { cstpTxExtInps = nExtInps } | nExtInps <- collapseValues cstpTxExtInps] - ++ - [ params { cstpTxOwnInps = nOwnInps } | nOwnInps <- collapseValues cstpTxOwnInps] - ++ - [ params { cstpOwnUtxos = nOwnUtxos } | nOwnUtxos <- collapseValues cstpOwnUtxos] +shrinkParams params@CoinSelectionTestParams {..} = + [params {cstpTxOuts = nOuts} | nOuts <- shrinkValues cstpTxOuts] + ++ [params {cstpTxMint = nMint} | nMint <- shrinkValue cstpTxMint] + ++ [params {cstpTxExtInps = nExtInps} | nExtInps <- shrinkValues cstpTxExtInps] + ++ [params {cstpTxOwnInps = nOwnInps} | nOwnInps <- shrinkValues cstpTxOwnInps] + ++ [params {cstpOwnUtxos = nOwnUtxos} | nOwnUtxos <- shrinkValues cstpOwnUtxos] + ++ [params {cstpTxOuts = nOuts} | nOuts <- collapseValues cstpTxOuts] + ++ [params {cstpTxExtInps = nExtInps} | nExtInps <- collapseValues cstpTxExtInps] + ++ [params {cstpTxOwnInps = nOwnInps} | nOwnInps <- collapseValues cstpTxOwnInps] + ++ [params {cstpOwnUtxos = nOwnUtxos} | nOwnUtxos <- collapseValues cstpOwnUtxos] -- To collapseValues we take every possible pair and try to add them together. collapseValues :: [GYValue] -> [[GYValue]] -collapseValues [] = [] +collapseValues [] = [] collapseValues [_] = [[]] -collapseValues vs = [] : [mconcat vs] : [(v <> v') : (vs \\ [v,v']) | (v,v') <- pairs vs] +collapseValues vs = [] : [mconcat vs] : [(v <> v') : (vs \\ [v, v']) | (v, v') <- pairs vs] shrinkExtraLovelace :: Natural -> [Natural] shrinkExtraLovelace el = [nEl | nEl <- extraLovelaceValues, nEl < el] @@ -626,8 +655,9 @@ shrinkValues = map removeEmpties . shrinkList shrinkValue removeEmpties :: [GYValue] -> [GYValue] removeEmpties [] = [] -removeEmpties (x:xs) | x == mempty = removeEmpties xs - | otherwise = x : removeEmpties xs +removeEmpties (x : xs) + | x == mempty = removeEmpties xs + | otherwise = x : removeEmpties xs ------------------------------------------------------------------------------- -- QuickCheck Utils @@ -642,19 +672,19 @@ prettyParamsLovelace (params, el) = prettyTestParams params ++ "\n* ExtraLovelac -} inputsAreValid :: [GYValue] -> Natural -> ([GYValue], [GYValue], [GYValue], GYValue) -> Bool inputsAreValid outs extraLovelace (extIns, ownIns, ownUtxos, minted) = - mconcat (minted : extIns ++ ownIns ++ ownUtxos) `valueGreaterOrEqual` (mconcat outs <> naturalToValue extraLovelace) + mconcat (minted : extIns ++ ownIns ++ ownUtxos) `valueGreaterOrEqual` (mconcat outs <> naturalToValue extraLovelace) -- Easier way to call `inputsAreValid` for a given CoinSelectionTestParams paramsInputsAreValid :: Natural -> CoinSelectionTestParams -> Bool -paramsInputsAreValid eLovelace CoinSelectionTestParams{..} = - inputsAreValid cstpTxOuts eLovelace (cstpTxExtInps, cstpTxOwnInps, cstpOwnUtxos, cstpTxMint) +paramsInputsAreValid eLovelace CoinSelectionTestParams {..} = + inputsAreValid cstpTxOuts eLovelace (cstpTxExtInps, cstpTxOwnInps, cstpOwnUtxos, cstpTxMint) naturalToValue :: Natural -> GYValue naturalToValue = valueFromLovelace . toInteger -- Get all possible pairs of values from a list, without duplicates pairs :: [a] -> [(a, a)] -pairs l = [(x,y) | (x:ys) <- tails l, y <- ys] +pairs l = [(x, y) | (x : ys) <- tails l, y <- ys] extraLovelaceValues :: [Natural] extraLovelaceValues = [2_000_000, 4_000_000 .. 10_000_000] diff --git a/tests/GeniusYield/Test/Config.hs b/tests/GeniusYield/Test/Config.hs index bd88fc1f..4a3d7364 100644 --- a/tests/GeniusYield/Test/Config.hs +++ b/tests/GeniusYield/Test/Config.hs @@ -1,25 +1,27 @@ module GeniusYield.Test.Config ( - configTests + configTests, ) where -import System.FilePath +import System.FilePath -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertBool, testCase) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase) -import GeniusYield.GYConfig +import GeniusYield.GYConfig -- | These tests check that we can parse configs configTests :: TestTree -configTests = testGroup "Config" - [ testCase "core-local" $ testParseResult isNodeKupo "core-local.json" - , testCase "core-maestro" $ testParseResult isMaestro "core-maestro.json" - , testCase "core-blockfrost" $ testParseResult isBlockfrost "core-blockfrost.json" +configTests = + testGroup + "Config" + [ testCase "core-local" $ testParseResult isNodeKupo "core-local.json" + , testCase "core-maestro" $ testParseResult isMaestro "core-maestro.json" + , testCase "core-blockfrost" $ testParseResult isBlockfrost "core-blockfrost.json" ] testParseResult :: (GYCoreProviderInfo -> Bool) -> FilePath -> IO () testParseResult expectation filePath = - coreProviderIO (mockConfigDir filePath) >>= assertBool "parses as expected" . expectation + coreProviderIO (mockConfigDir filePath) >>= assertBool "parses as expected" . expectation mockConfigDir :: FilePath mockConfigDir = "tests/mock-configs" diff --git a/tests/GeniusYield/Test/GYTxBody.hs b/tests/GeniusYield/Test/GYTxBody.hs index cfc9d469..e01b18c0 100644 --- a/tests/GeniusYield/Test/GYTxBody.hs +++ b/tests/GeniusYield/Test/GYTxBody.hs @@ -1,95 +1,133 @@ -module GeniusYield.Test.GYTxBody - ( gyTxBodyTests - , mockTxId - ) where - -import qualified Cardano.Api as Api -import qualified Data.Set as Set (empty) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Numeric.Natural (Natural) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, testCase, - (@?=)) - -import Clb.MockConfig (defaultConwayParams, - defaultSlotConfig) -import Clb.TimeSlot (SlotConfig (..)) - -import GeniusYield.Types.Address (GYAddress, - unsafeAddressFromText) -import GeniusYield.Types.SlotConfig (gyscSystemStart, - simpleSlotConfig) -import GeniusYield.Types.Time (timeFromPlutus, - timeToPOSIX) -import GeniusYield.Types.Tx (GYTxId) -import GeniusYield.Types.TxOut (GYTxOut, - mkGYTxOutNoDatum) -import GeniusYield.Types.TxOutRef (GYTxOutRef, - txOutRefFromTuple) -import GeniusYield.Types.UTxO (GYOutDatum (GYOutDatumNone), - GYUTxO (..), GYUTxOs, - utxosFromList) -import GeniusYield.Types.Value (GYAssetClass (..), - GYTokenName, GYValue, - valueFromList, - valueFromLovelace, - valueSingleton) - -import GeniusYield.Providers.Common (mainnetEraHist) -import GeniusYield.Transaction (GYBuildTxEnv (..), - GYCoinSelectionStrategy (..), - balanceTxStep) -import GeniusYield.Transaction.Common (GYBalancingError (..), - adjustTxOut, minimumUTxO) -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) +module GeniusYield.Test.GYTxBody ( + gyTxBodyTests, + mockTxId, +) where + +import Cardano.Api qualified as Api +import Data.Set qualified as Set (empty) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Numeric.Natural (Natural) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ( + Assertion, + testCase, + (@?=), + ) + +import Clb.MockConfig ( + defaultConwayParams, + defaultSlotConfig, + ) +import Clb.TimeSlot (SlotConfig (..)) + +import GeniusYield.Types.Address ( + GYAddress, + unsafeAddressFromText, + ) +import GeniusYield.Types.SlotConfig ( + gyscSystemStart, + simpleSlotConfig, + ) +import GeniusYield.Types.Time ( + timeFromPlutus, + timeToPOSIX, + ) +import GeniusYield.Types.Tx (GYTxId) +import GeniusYield.Types.TxOut ( + GYTxOut, + mkGYTxOutNoDatum, + ) +import GeniusYield.Types.TxOutRef ( + GYTxOutRef, + txOutRefFromTuple, + ) +import GeniusYield.Types.UTxO ( + GYOutDatum (GYOutDatumNone), + GYUTxO (..), + GYUTxOs, + utxosFromList, + ) +import GeniusYield.Types.Value ( + GYAssetClass (..), + GYTokenName, + GYValue, + valueFromList, + valueFromLovelace, + valueSingleton, + ) + +import GeniusYield.Providers.Common (mainnetEraHist) +import GeniusYield.Transaction ( + GYBuildTxEnv (..), + GYCoinSelectionStrategy (..), + balanceTxStep, + ) +import GeniusYield.Transaction.Common ( + GYBalancingError (..), + adjustTxOut, + minimumUTxO, + ) +import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) + ------------------------------------------------------------------------------- -- Tests ------------------------------------------------------------------------------- gyTxBodyTests :: TestTree -gyTxBodyTests = testGroup "GYTxBody" [ testGroup "AdjustTx" adjustTxTests - , testGroup "BalanceTxStep" balanceTxStepTests - ] +gyTxBodyTests = + testGroup + "GYTxBody" + [ testGroup "AdjustTx" adjustTxTests + , testGroup "BalanceTxStep" balanceTxStepTests + ] adjustTxTests :: [TestTree] adjustTxTests = - [ testCase "No adjust needed" $ - 10_000_000 `lovelacesAdjustedShouldEqual` 10_000_000 - , testCase "Few ADA" $ - 2_000_000 `lovelacesAdjustedShouldEqual` 2_000_000 - , testCase "Very Few ADA" $ - 100_000 `lovelacesAdjustedShouldEqual` 969_750 - , testCase "ADA and Assets" $ do - let val = valueFromList [ (GYLovelace, 10_000_000) - , (mockAsset "A", 100) - , (mockAsset "B", 200) - ] - val `adjustedShouldEqual` val - , testCase "Few ADA and Assets" $ do - let val = valueFromList [ (GYLovelace, 2_000_000) - , (mockAsset "A", 100) - , (mockAsset "B", 200) - ] - val `adjustedShouldEqual` val - , testCase "Very Few ADA and Assets" $ do - let val = valueFromList [ (GYLovelace, 100_000) - , (mockAsset "A", 100) - , (mockAsset "B", 200) - ] - val `adjustedShouldEqual` (val <> valueFromLovelace 1_046_460) - , testCase "Very Few ADA and a lot of Assets" $ do - let val = valueFromList [ (GYLovelace, 100_000) - , (mockAsset "A", 1000) - , (mockAsset "B", 2000) - , (mockAsset "C", 3000) - , (mockAsset "D", 4000) - , (mockAsset "E", 5000) - , (mockAsset "F", 6000) - , (mockAsset "G", 7000) - , (mockAsset "H", 8000) - ] - val `adjustedShouldEqual` (val <> valueFromLovelace 1_184_380) - ] + [ testCase "No adjust needed" $ + 10_000_000 `lovelacesAdjustedShouldEqual` 10_000_000 + , testCase "Few ADA" $ + 2_000_000 `lovelacesAdjustedShouldEqual` 2_000_000 + , testCase "Very Few ADA" $ + 100_000 `lovelacesAdjustedShouldEqual` 969_750 + , testCase "ADA and Assets" $ do + let val = + valueFromList + [ (GYLovelace, 10_000_000) + , (mockAsset "A", 100) + , (mockAsset "B", 200) + ] + val `adjustedShouldEqual` val + , testCase "Few ADA and Assets" $ do + let val = + valueFromList + [ (GYLovelace, 2_000_000) + , (mockAsset "A", 100) + , (mockAsset "B", 200) + ] + val `adjustedShouldEqual` val + , testCase "Very Few ADA and Assets" $ do + let val = + valueFromList + [ (GYLovelace, 100_000) + , (mockAsset "A", 100) + , (mockAsset "B", 200) + ] + val `adjustedShouldEqual` (val <> valueFromLovelace 1_046_460) + , testCase "Very Few ADA and a lot of Assets" $ do + let val = + valueFromList + [ (GYLovelace, 100_000) + , (mockAsset "A", 1000) + , (mockAsset "B", 2000) + , (mockAsset "C", 3000) + , (mockAsset "D", 4000) + , (mockAsset "E", 5000) + , (mockAsset "F", 6000) + , (mockAsset "G", 7000) + , (mockAsset "H", 8000) + ] + val `adjustedShouldEqual` (val <> valueFromLovelace 1_184_380) + ] where mockAdjust :: GYTxOut v -> GYTxOut v mockAdjust = adjustTxOut mockMinimumUTxO @@ -99,45 +137,50 @@ adjustTxTests = lovelacesAdjustedShouldEqual :: Integer -> Integer -> Assertion lovelacesAdjustedShouldEqual n m = - mockAdjust (mockTxOutFromLovelace n) @?= mockTxOutFromLovelace m + mockAdjust (mockTxOutFromLovelace n) @?= mockTxOutFromLovelace m adjustedShouldEqual :: GYValue -> GYValue -> Assertion adjustedShouldEqual v1 v2 = mockAdjust (mockTxOut v1) @?= mockTxOut v2 balanceTxStepTests :: [TestTree] balanceTxStepTests = - [ testCase "Empty OwnUtxos" $ do - res <- balanceTxStep - (mockBuildTxEnv mempty) - Nothing - [] [] - [] - [] - GYRandomImproveMultiAsset - 2_000_000 - res @?= Left GYBalancingErrorEmptyOwnUTxOs - , testCase "No collateral needed" $ do - Right (_, collaterals, _) <- balanceTxStep - (mockBuildTxEnv [valueFromLovelace 10_000_000]) - Nothing - [] [] - [] - [] - GYRandomImproveMultiAsset - 2_000_000 - collaterals @?= utxosFromList [] - - , testCase "Collateral Needed" $ do - Right (_, collaterals, _) <- balanceTxStep - (mockBuildTxEnv [valueFromLovelace 10_000_000]) - (Just (valueSingleton (mockAsset "A") 100, [])) - [] [] - [] - [] - GYRandomImproveMultiAsset - 2_000_000 - collaterals @?= utxosFromList [collateralUtxo] - ] + [ testCase "Empty OwnUtxos" $ do + res <- + balanceTxStep + (mockBuildTxEnv mempty) + Nothing + [] + [] + [] + [] + GYRandomImproveMultiAsset + 2_000_000 + res @?= Left GYBalancingErrorEmptyOwnUTxOs + , testCase "No collateral needed" $ do + Right (_, collaterals, _) <- + balanceTxStep + (mockBuildTxEnv [valueFromLovelace 10_000_000]) + Nothing + [] + [] + [] + [] + GYRandomImproveMultiAsset + 2_000_000 + collaterals @?= utxosFromList [] + , testCase "Collateral Needed" $ do + Right (_, collaterals, _) <- + balanceTxStep + (mockBuildTxEnv [valueFromLovelace 10_000_000]) + (Just (valueSingleton (mockAsset "A") 100, [])) + [] + [] + [] + [] + GYRandomImproveMultiAsset + 2_000_000 + collaterals @?= utxosFromList [collateralUtxo] + ] ------------------------------------------------------------------------------- -- Mock Values @@ -168,37 +211,45 @@ mockProtocolParams :: ApiProtocolParameters mockProtocolParams = defaultConwayParams collateralUtxo :: GYUTxO -collateralUtxo = GYUTxO - { utxoRef = mockTxOutRef - , utxoAddress = mockChangeAddress - , utxoValue = valueFromLovelace 1_234_567 - , utxoOutDatum = GYOutDatumNone +collateralUtxo = + GYUTxO + { utxoRef = mockTxOutRef + , utxoAddress = mockChangeAddress + , utxoValue = valueFromLovelace 1_234_567 + , utxoOutDatum = GYOutDatumNone , utxoRefScript = Nothing } mockBuildTxEnv :: [GYValue] -> GYBuildTxEnv -mockBuildTxEnv wallet = GYBuildTxEnv - { gyBTxEnvSystemStart = mockSystemStart - , gyBTxEnvEraHistory = Api.EraHistory mainnetEraHist +mockBuildTxEnv wallet = + GYBuildTxEnv + { gyBTxEnvSystemStart = mockSystemStart + , gyBTxEnvEraHistory = Api.EraHistory mainnetEraHist , gyBTxEnvProtocolParams = mockProtocolParams - , gyBTxEnvPools = Set.empty - , gyBTxEnvOwnUtxos = buildOwnUtxos wallet - , gyBTxEnvChangeAddr = mockChangeAddress - , gyBTxEnvCollateral = collateralUtxo + , gyBTxEnvPools = Set.empty + , gyBTxEnvOwnUtxos = buildOwnUtxos wallet + , gyBTxEnvChangeAddr = mockChangeAddress + , gyBTxEnvCollateral = collateralUtxo } where slotLen = fromInteger (scSlotLength defaultSlotConfig) / 1000 - slotZero = posixSecondsToUTCTime $ timeToPOSIX $ timeFromPlutus $ - scSlotZeroTime defaultSlotConfig + slotZero = + posixSecondsToUTCTime $ + timeToPOSIX $ + timeFromPlutus $ + scSlotZeroTime defaultSlotConfig mockSystemStart = gyscSystemStart $ simpleSlotConfig slotZero slotLen buildOwnUtxos :: [GYValue] -> GYUTxOs -buildOwnUtxos = utxosFromList . zipWith - (\i v -> GYUTxO - (txOutRefFromTuple (mockTxId, i)) - mockChangeAddress - v - GYOutDatumNone - Nothing - ) - [0..] +buildOwnUtxos = + utxosFromList + . zipWith + ( \i v -> + GYUTxO + (txOutRefFromTuple (mockTxId, i)) + mockChangeAddress + v + GYOutDatumNone + Nothing + ) + [0 ..] diff --git a/tests/GeniusYield/Test/GYTxSkeleton.hs b/tests/GeniusYield/Test/GYTxSkeleton.hs index 95e33f20..10c9aa79 100644 --- a/tests/GeniusYield/Test/GYTxSkeleton.hs +++ b/tests/GeniusYield/Test/GYTxSkeleton.hs @@ -1,41 +1,62 @@ -module GeniusYield.Test.GYTxSkeleton - ( gyTxSkeletonTests - ) where +module GeniusYield.Test.GYTxSkeleton ( + gyTxSkeletonTests, +) where -import Data.Either (fromRight) -import Data.Map as Map (Map, empty, fromList, - singleton) -import Data.Maybe (fromJust) -import Data.Set as Set (fromList, singleton) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Data.Either (fromRight) +import Data.Map as Map ( + Map, + empty, + fromList, + singleton, + ) +import Data.Maybe (fromJust) +import Data.Set as Set (fromList, singleton) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) -import GeniusYield.Types.Address (GYAddress, - unsafeAddressFromText) -import GeniusYield.Types.PlutusVersion (PlutusVersion (PlutusV2)) -import GeniusYield.Types.PubKeyHash (GYPubKeyHash, - pubKeyHashFromPlutus) -import GeniusYield.Types.Redeemer (GYRedeemer, unitRedeemer) -import GeniusYield.Types.Script (GYMintScript (..), - mintingPolicyFromApi, - scriptFromCBOR, scriptToApi) -import GeniusYield.Types.Slot (GYSlot, slotFromInteger) -import GeniusYield.Types.TxIn (GYTxIn (GYTxIn, gyTxInTxOutRef, gyTxInWitness), - GYTxInWitness (GYTxInWitnessKey)) -import GeniusYield.Types.TxOut (GYTxOut, mkGYTxOutNoDatum) -import GeniusYield.Types.TxOutRef (GYTxOutRef) -import GeniusYield.Types.Value (GYTokenName, GYValue, - unsafeTokenNameFromHex, - valueFromLovelace) +import GeniusYield.Types.Address ( + GYAddress, + unsafeAddressFromText, + ) +import GeniusYield.Types.PlutusVersion (PlutusVersion (PlutusV2)) +import GeniusYield.Types.PubKeyHash ( + GYPubKeyHash, + pubKeyHashFromPlutus, + ) +import GeniusYield.Types.Redeemer (GYRedeemer, unitRedeemer) +import GeniusYield.Types.Script ( + GYMintScript (..), + mintingPolicyFromApi, + scriptFromCBOR, + scriptToApi, + ) +import GeniusYield.Types.Slot (GYSlot, slotFromInteger) +import GeniusYield.Types.TxIn ( + GYTxIn (GYTxIn, gyTxInTxOutRef, gyTxInWitness), + GYTxInWitness (GYTxInWitnessKey), + ) +import GeniusYield.Types.TxOut (GYTxOut, mkGYTxOutNoDatum) +import GeniusYield.Types.TxOutRef (GYTxOutRef) +import GeniusYield.Types.Value ( + GYTokenName, + GYValue, + unsafeTokenNameFromHex, + valueFromLovelace, + ) + +import GeniusYield.TxBuilder.Class ( + GYTxSkeleton (..), + GYTxSkeletonRefIns (..), + isInvalidAfter, + isInvalidBefore, + mustBeSignedBy, + mustHaveInput, + mustHaveOptionalOutput, + mustHaveOutput, + mustHaveRefInput, + mustMint, + ) -import GeniusYield.TxBuilder.Class (GYTxSkeleton (..), - GYTxSkeletonRefIns (..), - isInvalidAfter, - isInvalidBefore, - mustBeSignedBy, mustHaveInput, - mustHaveOptionalOutput, - mustHaveOutput, - mustHaveRefInput, mustMint) ------------------------------------------------------------------------------- -- Tests ------------------------------------------------------------------------------- @@ -45,155 +66,163 @@ gyTxSkeletonTests = testGroup "GYTxSkeleton" basicTests basicTests :: [TestTree] basicTests = - [ testGroup "Constructors" - [ testCase "mustHaveInput" $ - gytxIns (mustHaveInput mockTxIn) @?= [mockTxIn] - , testCase "mustHaveReferenceInput" $ - gytxRefIns (mustHaveRefInput @'PlutusV2 mockTxOutRef) @?= GYTxSkeletonRefIns (Set.singleton mockTxOutRef) - , testCase "mustHaveOutput" $ - gytxOuts (mustHaveOutput mockTxOut1) @?= [mockTxOut1] - , testCase "mustHaveOptionalOutput (Just x)" $ - gytxOuts (mustHaveOptionalOutput (Just mockTxOut1)) @?= [mockTxOut1] - , testCase "mustHaveOptionalOutput (Nothing)" $ - gytxOuts (mustHaveOptionalOutput Nothing) @?= [] - , testCase "mustMint" $ - gytxMint (mustMint mockMintingPolicy unitRedeemer mockTokenName 10) @?= mockMint - , testCase "mustMint 0 is empty" $ - gytxMint (mustMint mockMintingPolicy unitRedeemer mockTokenName 0) @?= Map.empty - , testCase "mustMint when burning" $ - gytxMint (mustMint mockMintingPolicy unitRedeemer mockTokenName (-10)) @?= mockBurn - , testCase "mustBeSignedBy" $ - gytxSigs (mustBeSignedBy mockPkh1) @?= Set.singleton mockPkh1 - , testCase "isInvalidBefore" $ - gytxInvalidBefore (isInvalidBefore mockSlot) @?= Just mockSlot - , testCase "isInvalidAfter" $ - gytxInvalidAfter (isInvalidAfter mockSlot) @?= Just mockSlot - ] - , testGroup "SemiGroup" - [testGroup "Input" - [ testCase "Adding two inputs" $ - let skeleton1 = mustHaveInput mockTxIn - skeleton2 = mustHaveInput mockTxIn1 - newSkeleton = skeleton1 <> skeleton2 in - gytxIns newSkeleton @?= [mockTxIn, mockTxIn1] - , testCase "Adding the same inputs" $ - let skeleton1 = mustHaveInput mockTxIn - skeleton2 = mustHaveInput mockTxIn - newSkeleton = skeleton1 <> skeleton2 in - gytxIns newSkeleton @?= [mockTxIn] - ] - , testGroup "Ref Input" - [ testCase "Adding two reference inputs - Just/Just" $ - let skeleton1 = mustHaveRefInput mockTxOutRef - skeleton2 = mustHaveRefInput mockTxOutRef1 - newSkeleton = skeleton1 <> skeleton2 :: GYTxSkeleton 'PlutusV2 in - gytxRefIns newSkeleton @?= GYTxSkeletonRefIns (Set.fromList [mockTxOutRef, mockTxOutRef1]) - , testCase "Adding two reference inputs - Just/Nothing" $ - let skeleton1 = mustHaveRefInput mockTxOutRef - skeleton2 = mustHaveOptionalOutput Nothing -- This won't have any refInputs - newSkeleton = skeleton1 <> skeleton2 :: GYTxSkeleton 'PlutusV2 in - gytxRefIns newSkeleton @?= GYTxSkeletonRefIns (Set.singleton mockTxOutRef) - , testCase "Adding two reference inputs - Nothing/Just" $ - let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have any refInputs - skeleton2 = mustHaveRefInput mockTxOutRef - newSkeleton = skeleton1 <> skeleton2 :: GYTxSkeleton 'PlutusV2 in - gytxRefIns newSkeleton @?= GYTxSkeletonRefIns (Set.singleton mockTxOutRef) - , testCase "Adding two reference inputs - Nothing/Nothing" $ - let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have any refInputs - newSkeleton = skeleton1 <> skeleton1 :: GYTxSkeleton 'PlutusV2 in - gytxRefIns newSkeleton @?= GYTxSkeletonNoRefIns - ] - , testGroup "Output" - [ testCase "Adding two outputs" $ - let skeleton1 = mustHaveOutput mockTxOut1 - skeleton2 = mustHaveOutput mockTxOut2 - newSkeleton = skeleton1 <> skeleton2 in - gytxOuts newSkeleton @?= [mockTxOut1, mockTxOut2] - , testCase "Adding the same outputs" $ - let skeleton1 = mustHaveOutput mockTxOut1 - skeleton2 = mustHaveOutput mockTxOut1 - newSkeleton = skeleton1 <> skeleton2 in - gytxOuts newSkeleton @?= [mockTxOut1, mockTxOut1] - ] - , testGroup "Mint" - [ testCase "Adding two mints - same token" $ - let skeleton1 = mustMint mockMintingPolicy unitRedeemer mockTokenName 10 - skeleton2 = mustMint mockMintingPolicy unitRedeemer mockTokenName 20 - newSkeleton = skeleton1 <> skeleton2 in - gytxMint newSkeleton @?= mockMint' 30 - , testCase "Adding one mint and one burn" $ - let skeleton1 = mustMint mockMintingPolicy unitRedeemer mockTokenName 10 - skeleton2 = mustMint mockMintingPolicy unitRedeemer mockTokenName (-20) - newSkeleton = skeleton1 <> skeleton2 in - gytxMint newSkeleton @?= mockMint' (-10) - , testCase "Adding two burns" $ - let skeleton1 = mustMint mockMintingPolicy unitRedeemer mockTokenName (-10) - skeleton2 = mustMint mockMintingPolicy unitRedeemer mockTokenName (-20) - newSkeleton = skeleton1 <> skeleton2 in - gytxMint newSkeleton @?= mockMint' (-30) - , testCase "Adding two mints - different tokens" $ - let skeleton1 = mustMint mockMintingPolicy unitRedeemer mockTokenName 10 - skeleton2 = mustMint mockMintingPolicy unitRedeemer mockTokenName1 20 - newSkeleton = skeleton1 <> skeleton2 in - gytxMint newSkeleton @?= mockMintSum - ] - , testGroup "Required Signers" - [ testCase "Adding two required signers" $ - let skeleton1 = mustBeSignedBy mockPkh1 - skeleton2 = mustBeSignedBy mockPkh2 - newSkeleton = skeleton1 <> skeleton2 in - gytxSigs newSkeleton @?= Set.fromList [mockPkh1, mockPkh2] - , testCase "Adding the same required signers" $ - let skeleton1 = mustBeSignedBy mockPkh1 - skeleton2 = mustBeSignedBy mockPkh1 - newSkeleton = skeleton1 <> skeleton2 in - gytxSigs newSkeleton @?= Set.singleton mockPkh1 - ] - , testGroup "InvalidBefore" - [ testCase "Adding two invalidBefore - Just/Just" $ - let skeleton1 = isInvalidBefore $ mockSlot' 1000 - skeleton2 = isInvalidBefore $ mockSlot' 2000 - newSkeleton = skeleton1 <> skeleton2 in - gytxInvalidBefore newSkeleton @?= Just (mockSlot' 2000) - , testCase "Adding two invalidBefore - Just/Nothing" $ - let skeleton1 = isInvalidBefore $ mockSlot' 1000 - skeleton2 = mustHaveOptionalOutput Nothing -- This won't have isInvalidBefore set - newSkeleton = skeleton1 <> skeleton2 in - gytxInvalidBefore newSkeleton @?= Just (mockSlot' 1000) - , testCase "Adding two invalidBefore - Nothing/Just" $ - let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have isInvalidBefore set - skeleton2 = isInvalidBefore $ mockSlot' 1000 - newSkeleton = skeleton1 <> skeleton2 in - gytxInvalidBefore newSkeleton @?= Just (mockSlot' 1000) - , testCase "Adding two invalidBefore - Nothing/Nothing" $ - let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have isInvalidBefore set - newSkeleton = skeleton1 <> skeleton1 in - gytxInvalidBefore newSkeleton @?= Nothing - ] - , testGroup "InvalidAfter" - [ testCase "Adding two invalidAfter - Just/Just" $ - let skeleton1 = isInvalidAfter $ mockSlot' 1000 - skeleton2 = isInvalidAfter $ mockSlot' 2000 - newSkeleton = skeleton1 <> skeleton2 in - gytxInvalidAfter newSkeleton @?= Just (mockSlot' 1000) - , testCase "Adding two invalidAfter - Just/Nothing" $ - let skeleton1 = isInvalidAfter $ mockSlot' 2000 - skeleton2 = mustHaveOptionalOutput Nothing -- This won't have isInvalidAfter set - newSkeleton = skeleton1 <> skeleton2 in - gytxInvalidAfter newSkeleton @?= Just (mockSlot' 2000) - , testCase "Adding two invalidAfter - Nothing/Just" $ - let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have isInvalidAfter set - skeleton2 = isInvalidAfter $ mockSlot' 2000 - newSkeleton = skeleton1 <> skeleton2 in - gytxInvalidAfter newSkeleton @?= Just (mockSlot' 2000) - , testCase "Adding two invalidAfter - Nothing/Nothing" $ - let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have isInvalidAfter set - newSkeleton = skeleton1 <> skeleton1 in - gytxInvalidAfter newSkeleton @?= Nothing - ] - ] - ] - + [ testGroup + "Constructors" + [ testCase "mustHaveInput" $ + gytxIns (mustHaveInput mockTxIn) @?= [mockTxIn] + , testCase "mustHaveReferenceInput" $ + gytxRefIns (mustHaveRefInput @'PlutusV2 mockTxOutRef) @?= GYTxSkeletonRefIns (Set.singleton mockTxOutRef) + , testCase "mustHaveOutput" $ + gytxOuts (mustHaveOutput mockTxOut1) @?= [mockTxOut1] + , testCase "mustHaveOptionalOutput (Just x)" $ + gytxOuts (mustHaveOptionalOutput (Just mockTxOut1)) @?= [mockTxOut1] + , testCase "mustHaveOptionalOutput (Nothing)" $ + gytxOuts (mustHaveOptionalOutput Nothing) @?= [] + , testCase "mustMint" $ + gytxMint (mustMint mockMintingPolicy unitRedeemer mockTokenName 10) @?= mockMint + , testCase "mustMint 0 is empty" $ + gytxMint (mustMint mockMintingPolicy unitRedeemer mockTokenName 0) @?= Map.empty + , testCase "mustMint when burning" $ + gytxMint (mustMint mockMintingPolicy unitRedeemer mockTokenName (-10)) @?= mockBurn + , testCase "mustBeSignedBy" $ + gytxSigs (mustBeSignedBy mockPkh1) @?= Set.singleton mockPkh1 + , testCase "isInvalidBefore" $ + gytxInvalidBefore (isInvalidBefore mockSlot) @?= Just mockSlot + , testCase "isInvalidAfter" $ + gytxInvalidAfter (isInvalidAfter mockSlot) @?= Just mockSlot + ] + , testGroup + "SemiGroup" + [ testGroup + "Input" + [ testCase "Adding two inputs" $ + let skeleton1 = mustHaveInput mockTxIn + skeleton2 = mustHaveInput mockTxIn1 + newSkeleton = skeleton1 <> skeleton2 + in gytxIns newSkeleton @?= [mockTxIn, mockTxIn1] + , testCase "Adding the same inputs" $ + let skeleton1 = mustHaveInput mockTxIn + skeleton2 = mustHaveInput mockTxIn + newSkeleton = skeleton1 <> skeleton2 + in gytxIns newSkeleton @?= [mockTxIn] + ] + , testGroup + "Ref Input" + [ testCase "Adding two reference inputs - Just/Just" $ + let skeleton1 = mustHaveRefInput mockTxOutRef + skeleton2 = mustHaveRefInput mockTxOutRef1 + newSkeleton = skeleton1 <> skeleton2 :: GYTxSkeleton 'PlutusV2 + in gytxRefIns newSkeleton @?= GYTxSkeletonRefIns (Set.fromList [mockTxOutRef, mockTxOutRef1]) + , testCase "Adding two reference inputs - Just/Nothing" $ + let skeleton1 = mustHaveRefInput mockTxOutRef + skeleton2 = mustHaveOptionalOutput Nothing -- This won't have any refInputs + newSkeleton = skeleton1 <> skeleton2 :: GYTxSkeleton 'PlutusV2 + in gytxRefIns newSkeleton @?= GYTxSkeletonRefIns (Set.singleton mockTxOutRef) + , testCase "Adding two reference inputs - Nothing/Just" $ + let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have any refInputs + skeleton2 = mustHaveRefInput mockTxOutRef + newSkeleton = skeleton1 <> skeleton2 :: GYTxSkeleton 'PlutusV2 + in gytxRefIns newSkeleton @?= GYTxSkeletonRefIns (Set.singleton mockTxOutRef) + , testCase "Adding two reference inputs - Nothing/Nothing" $ + let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have any refInputs + newSkeleton = skeleton1 <> skeleton1 :: GYTxSkeleton 'PlutusV2 + in gytxRefIns newSkeleton @?= GYTxSkeletonNoRefIns + ] + , testGroup + "Output" + [ testCase "Adding two outputs" $ + let skeleton1 = mustHaveOutput mockTxOut1 + skeleton2 = mustHaveOutput mockTxOut2 + newSkeleton = skeleton1 <> skeleton2 + in gytxOuts newSkeleton @?= [mockTxOut1, mockTxOut2] + , testCase "Adding the same outputs" $ + let skeleton1 = mustHaveOutput mockTxOut1 + skeleton2 = mustHaveOutput mockTxOut1 + newSkeleton = skeleton1 <> skeleton2 + in gytxOuts newSkeleton @?= [mockTxOut1, mockTxOut1] + ] + , testGroup + "Mint" + [ testCase "Adding two mints - same token" $ + let skeleton1 = mustMint mockMintingPolicy unitRedeemer mockTokenName 10 + skeleton2 = mustMint mockMintingPolicy unitRedeemer mockTokenName 20 + newSkeleton = skeleton1 <> skeleton2 + in gytxMint newSkeleton @?= mockMint' 30 + , testCase "Adding one mint and one burn" $ + let skeleton1 = mustMint mockMintingPolicy unitRedeemer mockTokenName 10 + skeleton2 = mustMint mockMintingPolicy unitRedeemer mockTokenName (-20) + newSkeleton = skeleton1 <> skeleton2 + in gytxMint newSkeleton @?= mockMint' (-10) + , testCase "Adding two burns" $ + let skeleton1 = mustMint mockMintingPolicy unitRedeemer mockTokenName (-10) + skeleton2 = mustMint mockMintingPolicy unitRedeemer mockTokenName (-20) + newSkeleton = skeleton1 <> skeleton2 + in gytxMint newSkeleton @?= mockMint' (-30) + , testCase "Adding two mints - different tokens" $ + let skeleton1 = mustMint mockMintingPolicy unitRedeemer mockTokenName 10 + skeleton2 = mustMint mockMintingPolicy unitRedeemer mockTokenName1 20 + newSkeleton = skeleton1 <> skeleton2 + in gytxMint newSkeleton @?= mockMintSum + ] + , testGroup + "Required Signers" + [ testCase "Adding two required signers" $ + let skeleton1 = mustBeSignedBy mockPkh1 + skeleton2 = mustBeSignedBy mockPkh2 + newSkeleton = skeleton1 <> skeleton2 + in gytxSigs newSkeleton @?= Set.fromList [mockPkh1, mockPkh2] + , testCase "Adding the same required signers" $ + let skeleton1 = mustBeSignedBy mockPkh1 + skeleton2 = mustBeSignedBy mockPkh1 + newSkeleton = skeleton1 <> skeleton2 + in gytxSigs newSkeleton @?= Set.singleton mockPkh1 + ] + , testGroup + "InvalidBefore" + [ testCase "Adding two invalidBefore - Just/Just" $ + let skeleton1 = isInvalidBefore $ mockSlot' 1000 + skeleton2 = isInvalidBefore $ mockSlot' 2000 + newSkeleton = skeleton1 <> skeleton2 + in gytxInvalidBefore newSkeleton @?= Just (mockSlot' 2000) + , testCase "Adding two invalidBefore - Just/Nothing" $ + let skeleton1 = isInvalidBefore $ mockSlot' 1000 + skeleton2 = mustHaveOptionalOutput Nothing -- This won't have isInvalidBefore set + newSkeleton = skeleton1 <> skeleton2 + in gytxInvalidBefore newSkeleton @?= Just (mockSlot' 1000) + , testCase "Adding two invalidBefore - Nothing/Just" $ + let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have isInvalidBefore set + skeleton2 = isInvalidBefore $ mockSlot' 1000 + newSkeleton = skeleton1 <> skeleton2 + in gytxInvalidBefore newSkeleton @?= Just (mockSlot' 1000) + , testCase "Adding two invalidBefore - Nothing/Nothing" $ + let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have isInvalidBefore set + newSkeleton = skeleton1 <> skeleton1 + in gytxInvalidBefore newSkeleton @?= Nothing + ] + , testGroup + "InvalidAfter" + [ testCase "Adding two invalidAfter - Just/Just" $ + let skeleton1 = isInvalidAfter $ mockSlot' 1000 + skeleton2 = isInvalidAfter $ mockSlot' 2000 + newSkeleton = skeleton1 <> skeleton2 + in gytxInvalidAfter newSkeleton @?= Just (mockSlot' 1000) + , testCase "Adding two invalidAfter - Just/Nothing" $ + let skeleton1 = isInvalidAfter $ mockSlot' 2000 + skeleton2 = mustHaveOptionalOutput Nothing -- This won't have isInvalidAfter set + newSkeleton = skeleton1 <> skeleton2 + in gytxInvalidAfter newSkeleton @?= Just (mockSlot' 2000) + , testCase "Adding two invalidAfter - Nothing/Just" $ + let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have isInvalidAfter set + skeleton2 = isInvalidAfter $ mockSlot' 2000 + newSkeleton = skeleton1 <> skeleton2 + in gytxInvalidAfter newSkeleton @?= Just (mockSlot' 2000) + , testCase "Adding two invalidAfter - Nothing/Nothing" $ + let skeleton1 = mustHaveOptionalOutput Nothing -- This won't have isInvalidAfter set + newSkeleton = skeleton1 <> skeleton1 + in gytxInvalidAfter newSkeleton @?= Nothing + ] + ] + ] ------------------------------------------------------------------------------- -- Mock Values @@ -256,9 +285,15 @@ mockTxOutRef1 :: GYTxOutRef mockTxOutRef1 = "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189#0" mockTxIn :: GYTxIn v -mockTxIn = GYTxIn { gyTxInTxOutRef = mockTxOutRef - , gyTxInWitness = GYTxInWitnessKey} +mockTxIn = + GYTxIn + { gyTxInTxOutRef = mockTxOutRef + , gyTxInWitness = GYTxInWitnessKey + } mockTxIn1 :: GYTxIn v -mockTxIn1 = GYTxIn { gyTxInTxOutRef = mockTxOutRef1 - , gyTxInWitness = GYTxInWitnessKey} +mockTxIn1 = + GYTxIn + { gyTxInTxOutRef = mockTxOutRef1 + , gyTxInWitness = GYTxInWitnessKey + } diff --git a/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs b/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs index bc4b6eb5..d927d035 100644 --- a/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs +++ b/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs @@ -1,24 +1,24 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-| +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} + +{- | Module : GeniusYield.Test.OnChain.GuessRefInputDatum Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.com Stability : develop - -} -module GeniusYield.Test.OnChain.GuessRefInputDatum - ( mkGuessRefInputDatumValidator - , RefInputDatum (..) - , Guess (..) - ) where +module GeniusYield.Test.OnChain.GuessRefInputDatum ( + mkGuessRefInputDatumValidator, + RefInputDatum (..), + Guess (..), +) where -import PlutusLedgerApi.V2 -import PlutusLedgerApi.V2.Contexts (findDatum) -import qualified PlutusTx -import PlutusTx.Prelude as PlutusTx +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V2.Contexts (findDatum) +import PlutusTx qualified +import PlutusTx.Prelude as PlutusTx newtype RefInputDatum = RefInputDatum Integer PlutusTx.unstableMakeIsData ''RefInputDatum @@ -27,11 +27,11 @@ PlutusTx.unstableMakeIsData ''RefInputDatum newtype Guess = Guess Integer PlutusTx.unstableMakeIsData ''Guess -{-# INLINABLE mkGuessRefInputDatumValidator #-} +{-# INLINEABLE mkGuessRefInputDatumValidator #-} mkGuessRefInputDatumValidator :: BuiltinData -> BuiltinData -> BuiltinData -> () mkGuessRefInputDatumValidator _ red' ctx' - | guess == original = () - | otherwise = error () + | guess == original = () + | otherwise = error () where ctx :: ScriptContext ctx = unsafeFromBuiltinData ctx' @@ -43,19 +43,20 @@ mkGuessRefInputDatumValidator _ red' ctx' refIn :: TxOut refIn = case map txInInfoResolved (txInfoReferenceInputs info) of - [refIn'] -> refIn' - [] -> traceError "No reference input provided." - _anyOther -> traceError "Expected only one reference input but found more than one." + [refIn'] -> refIn' + [] -> traceError "No reference input provided." + _anyOther -> traceError "Expected only one reference input but found more than one." - outputToDatum :: FromData b => TxOut -> Maybe b + outputToDatum :: (FromData b) => TxOut -> Maybe b outputToDatum o = case txOutDatum o of - NoOutputDatum -> Nothing - OutputDatum d -> processDatum d + NoOutputDatum -> Nothing + OutputDatum d -> processDatum d OutputDatumHash dh -> processDatum =<< findDatum dh info - where processDatum = fromBuiltinData . getDatum + where + processDatum = fromBuiltinData . getDatum original :: Integer original = case outputToDatum refIn of - Nothing -> traceError "Datum not present or parsed." + Nothing -> traceError "Datum not present or parsed." Just (RefInputDatum original') -> original' diff --git a/tests/GeniusYield/Test/OnChain/GuessRefInputDatum/Compiled.hs b/tests/GeniusYield/Test/OnChain/GuessRefInputDatum/Compiled.hs index 7d46a640..39e56f84 100644 --- a/tests/GeniusYield/Test/OnChain/GuessRefInputDatum/Compiled.hs +++ b/tests/GeniusYield/Test/OnChain/GuessRefInputDatum/Compiled.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} -{-| + +{- | Module : GeniusYield.Test.OnChain.GuessRefInputDatum.Compiled Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.com Stability : develop - -} -module GeniusYield.Test.OnChain.GuessRefInputDatum.Compiled - ( guessRefInputDatumValidator - , RefInputDatum (..) - , Guess (..) - ) where +module GeniusYield.Test.OnChain.GuessRefInputDatum.Compiled ( + guessRefInputDatumValidator, + RefInputDatum (..), + Guess (..), +) where -import qualified PlutusTx +import PlutusTx qualified -import GeniusYield.Test.OnChain.GuessRefInputDatum +import GeniusYield.Test.OnChain.GuessRefInputDatum guessRefInputDatumValidator :: PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -guessRefInputDatumValidator = $$(PlutusTx.compile [|| mkGuessRefInputDatumValidator ||]) +guessRefInputDatumValidator = $$(PlutusTx.compile [||mkGuessRefInputDatumValidator||]) diff --git a/tests/GeniusYield/Test/Providers.hs b/tests/GeniusYield/Test/Providers.hs index 24b08c4b..448e9d0c 100644 --- a/tests/GeniusYield/Test/Providers.hs +++ b/tests/GeniusYield/Test/Providers.hs @@ -1,222 +1,278 @@ -module GeniusYield.Test.Providers - ( providersTests - ) where - -import Data.Aeson as Aeson (Value, decode, - decodeStrict) -import Data.ByteString.Lazy as BS (readFile, toStrict) -import Data.Map.Strict as Map (difference, - isSubmapOf) -import Data.Maybe (fromJust) -import qualified Data.Set as Set (difference, fromList, - isSubsetOf) -import qualified Data.Text as Text (Text, unpack) -import Test.Tasty -import Test.Tasty.Golden.Advanced (goldenTest) -import Test.Tasty.HUnit - -import GeniusYield.Types.Address (GYAddress, - unsafeAddressFromText) -import GeniusYield.Types.Datum (datumFromApi', - datumHashFromHex) -import GeniusYield.Types.Script (GYAnyScript (..), - mintingPolicyIdToText, - scriptFromCBOR) -import GeniusYield.Types.TxOutRef (GYTxOutRef) -import GeniusYield.Types.UTxO (GYOutDatum (..), - GYUTxO (..), utxosFromApi, - utxosFromList, utxosRefs, - utxosToApi) -import GeniusYield.Types.Value (GYAssetClass (GYLovelace, GYToken), - tokenNameToHex, - valueFromList, - valueFromLovelace) - -import qualified Cardano.Api as Api -import GeniusYield.GYConfig -import GeniusYield.Imports -import GeniusYield.Providers.Common (SomeDeserializeError (..)) -import GeniusYield.Providers.Maestro (maestroQueryUtxo, - networkIdToMaestroEnv, - utxoFromMaestro) -import GeniusYield.Test.Providers.Mashup (providersMashupTests) -import GeniusYield.Types (GYNetworkId, GYQueryUTxO, - PlutusVersion (PlutusV2), - gyQueryUtxoAtTxOutRef', - gyQueryUtxoRefsAtAddress', - gyQueryUtxosAtAddress', - gyQueryUtxosAtAddresses') -import GeniusYield.Types.Era -import qualified Maestro.Types.V1 as Maestro -import Web.HttpApiData (ToHttpApiData (..)) +module GeniusYield.Test.Providers ( + providersTests, +) where + +import Data.Aeson as Aeson ( + Value, + decode, + decodeStrict, + ) +import Data.ByteString.Lazy as BS (readFile, toStrict) +import Data.Map.Strict as Map ( + difference, + isSubmapOf, + ) +import Data.Maybe (fromJust) +import Data.Set qualified as Set ( + difference, + fromList, + isSubsetOf, + ) +import Data.Text qualified as Text (Text, unpack) +import Test.Tasty +import Test.Tasty.Golden.Advanced (goldenTest) +import Test.Tasty.HUnit + +import GeniusYield.Types.Address ( + GYAddress, + unsafeAddressFromText, + ) +import GeniusYield.Types.Datum ( + datumFromApi', + datumHashFromHex, + ) +import GeniusYield.Types.Script ( + GYAnyScript (..), + mintingPolicyIdToText, + scriptFromCBOR, + ) +import GeniusYield.Types.TxOutRef (GYTxOutRef) +import GeniusYield.Types.UTxO ( + GYOutDatum (..), + GYUTxO (..), + utxosFromApi, + utxosFromList, + utxosRefs, + utxosToApi, + ) +import GeniusYield.Types.Value ( + GYAssetClass (GYLovelace, GYToken), + tokenNameToHex, + valueFromList, + valueFromLovelace, + ) + +import Cardano.Api qualified as Api +import GeniusYield.GYConfig +import GeniusYield.Imports +import GeniusYield.Providers.Common (SomeDeserializeError (..)) +import GeniusYield.Providers.Maestro ( + maestroQueryUtxo, + networkIdToMaestroEnv, + utxoFromMaestro, + ) +import GeniusYield.Test.Providers.Mashup (providersMashupTests) +import GeniusYield.Types ( + GYNetworkId, + GYQueryUTxO, + PlutusVersion (PlutusV2), + gyQueryUtxoAtTxOutRef', + gyQueryUtxoRefsAtAddress', + gyQueryUtxosAtAddress', + gyQueryUtxosAtAddresses', + ) +import GeniusYield.Types.Era +import Maestro.Types.V1 qualified as Maestro +import Web.HttpApiData (ToHttpApiData (..)) providersTests :: [GYCoreConfig] -> Text.Text -> GYNetworkId -> TestTree -providersTests configs pToken netId = testGroup "Providers" [ testGroup "Maestro" (maestroTests pToken netId), providersMashupTests configs ] +providersTests configs pToken netId = testGroup "Providers" [testGroup "Maestro" (maestroTests pToken netId), providersMashupTests configs] maestroTests :: Text.Text -> GYNetworkId -> [TestTree] maestroTests token netId = - [ testGroup "Maestro Provider GYQueryUTxO" - [ goldenTestUtxos "UtxosAtAddress Simple" (getUTxOsAtAddress simpleQueryAddress token) (getFileUTxOs simpleAddressPath) - , goldenTestUtxos "UtxosAtAddress Complex" (getUTxOsAtAddress queryAddress1 token) (getFileUTxOs complexAddressPath) - , goldenTestUtxos "UtxosAtAddresses" (getUTxOsAtAddresses [queryAddress1, queryAddress2, queryAddress3] token) (getFileUTxOs utxosAtAddressesPath) - , goldenTestUtxos "UtxoAtRef" (getUTxOAtRef mockQueryTxOutRef token) (getFileUTxOs utxoAtRefPath) - , goldenTestRefs "UtxosRefsAtAddress" (getUTxOsRefsAtAddress simpleQueryAddress token) (getFileRefs simpleAddressPath) - ] - , testGroup "MaestroUtxo to GYUTxO translation" - [ testCase "Invalid Address" $ do - let expected = Left DeserializeErrorAddress - res = utxoFromMaestro $ Maestro.UtxoWithBytes - { utxoWithBytesTxHash = mockTxId - , utxoWithBytesIndex = mockTxIx - , utxoWithBytesAssets = [] - , utxoWithBytesAddress = "invalidaddress" - , utxoWithBytesDatum = Nothing - , utxoWithBytesReferenceScript = Nothing - , utxoWithBytesTxoutCbor = Nothing - } - res @?= expected - , testCase "Invalid UTxORef" $ do - let expected = Left (DeserializeErrorHex "GYTxOutRef: Failed reading: takeWhile1") - res = utxoFromMaestro $ Maestro.UtxoWithBytes - { utxoWithBytesTxHash = "invalidhash" - , utxoWithBytesIndex = mockTxIx - , utxoWithBytesAssets = [] - , utxoWithBytesAddress = mockAddressB32 - , utxoWithBytesDatum = Nothing - , utxoWithBytesReferenceScript = Nothing - , utxoWithBytesTxoutCbor = Nothing - } - res @?= expected - , testCase "Simplest Case" $ do - let expected = Right GYUTxO { utxoRef = mockTxOutRef - , utxoAddress = mockAddress - , utxoValue = valueFromList [] - , utxoOutDatum = GYOutDatumNone - , utxoRefScript = Nothing - } - res = utxoFromMaestro $ mockMaestroUtxo [] Nothing Nothing - res @?= expected - , testCase "Some Adas" $ do - let expected = Right GYUTxO { utxoRef = mockTxOutRef - , utxoAddress = mockAddress - , utxoValue = valueFromLovelace 100_000_000 - , utxoOutDatum = GYOutDatumNone - , utxoRefScript = Nothing - } - res = utxoFromMaestro $ mockMaestroUtxo [maestroAssetFromLovelace 100_000_000] Nothing Nothing - res @?= expected - , testCase "Some Adas and tokens" $ do - let expected = Right GYUTxO { utxoRef = mockTxOutRef - , utxoAddress = mockAddress - , utxoValue = valueFromList [ (GYLovelace, 100_000_000) - , (mockAssetA, 100) - , (mockAssetEmptyName, 1000) - ] - , utxoOutDatum = GYOutDatumNone - , utxoRefScript = Nothing - } - res = utxoFromMaestro $ mockMaestroUtxo [ maestroAssetFromLovelace 100_000_000 - , maestroAssetSingleton mockAssetA 100 - , maestroAssetSingleton mockAssetEmptyName 1000 - ] - Nothing - Nothing - res @?= expected - , testCase "Datum Hash" $ do - let expected = Right GYUTxO { utxoRef = mockTxOutRef - , utxoAddress = mockAddress - , utxoValue = valueFromList [] - , utxoOutDatum = GYOutDatumHash (fromJust $ datumHashFromHex $ Text.unpack mockDatumHashHex) - , utxoRefScript = Nothing - } - res = utxoFromMaestro $ mockMaestroUtxo [] (Just maestroDatumHash) Nothing - res @?= expected - , testCase "Datum Inline" $ do - let expected = Right GYUTxO { utxoRef = mockTxOutRef - , utxoAddress = mockAddress - , utxoValue = valueFromList [] - , utxoOutDatum = GYOutDatumInline $ datumFromApi' $ either (error "Unable to read mock datum") id $ Api.scriptDataFromJson Api.ScriptDataJsonDetailedSchema mockScriptDataDetailed - , utxoRefScript = Nothing - } - res = utxoFromMaestro $ mockMaestroUtxo [] (Just maestroInlineDatum) Nothing - res @?= expected - , testCase "Ref Script" $ do - let expected = Right GYUTxO { utxoRef = mockTxOutRef - , utxoAddress = mockAddress - , utxoValue = valueFromList [] - , utxoOutDatum = GYOutDatumNone - , utxoRefScript = GYPlutusScript <$> scriptFromCBOR @'PlutusV2 mockScriptCBOR - } - res = utxoFromMaestro $ mockMaestroUtxo [] Nothing (Just mockMaestroScript) - res @?= expected - ] - ] + [ testGroup + "Maestro Provider GYQueryUTxO" + [ goldenTestUtxos "UtxosAtAddress Simple" (getUTxOsAtAddress simpleQueryAddress token) (getFileUTxOs simpleAddressPath) + , goldenTestUtxos "UtxosAtAddress Complex" (getUTxOsAtAddress queryAddress1 token) (getFileUTxOs complexAddressPath) + , goldenTestUtxos "UtxosAtAddresses" (getUTxOsAtAddresses [queryAddress1, queryAddress2, queryAddress3] token) (getFileUTxOs utxosAtAddressesPath) + , goldenTestUtxos "UtxoAtRef" (getUTxOAtRef mockQueryTxOutRef token) (getFileUTxOs utxoAtRefPath) + , goldenTestRefs "UtxosRefsAtAddress" (getUTxOsRefsAtAddress simpleQueryAddress token) (getFileRefs simpleAddressPath) + ] + , testGroup + "MaestroUtxo to GYUTxO translation" + [ testCase "Invalid Address" $ do + let expected = Left DeserializeErrorAddress + res = + utxoFromMaestro $ + Maestro.UtxoWithBytes + { utxoWithBytesTxHash = mockTxId + , utxoWithBytesIndex = mockTxIx + , utxoWithBytesAssets = [] + , utxoWithBytesAddress = "invalidaddress" + , utxoWithBytesDatum = Nothing + , utxoWithBytesReferenceScript = Nothing + , utxoWithBytesTxoutCbor = Nothing + } + res @?= expected + , testCase "Invalid UTxORef" $ do + let expected = Left (DeserializeErrorHex "GYTxOutRef: Failed reading: takeWhile1") + res = + utxoFromMaestro $ + Maestro.UtxoWithBytes + { utxoWithBytesTxHash = "invalidhash" + , utxoWithBytesIndex = mockTxIx + , utxoWithBytesAssets = [] + , utxoWithBytesAddress = mockAddressB32 + , utxoWithBytesDatum = Nothing + , utxoWithBytesReferenceScript = Nothing + , utxoWithBytesTxoutCbor = Nothing + } + res @?= expected + , testCase "Simplest Case" $ do + let expected = + Right + GYUTxO + { utxoRef = mockTxOutRef + , utxoAddress = mockAddress + , utxoValue = valueFromList [] + , utxoOutDatum = GYOutDatumNone + , utxoRefScript = Nothing + } + res = utxoFromMaestro $ mockMaestroUtxo [] Nothing Nothing + res @?= expected + , testCase "Some Adas" $ do + let expected = + Right + GYUTxO + { utxoRef = mockTxOutRef + , utxoAddress = mockAddress + , utxoValue = valueFromLovelace 100_000_000 + , utxoOutDatum = GYOutDatumNone + , utxoRefScript = Nothing + } + res = utxoFromMaestro $ mockMaestroUtxo [maestroAssetFromLovelace 100_000_000] Nothing Nothing + res @?= expected + , testCase "Some Adas and tokens" $ do + let expected = + Right + GYUTxO + { utxoRef = mockTxOutRef + , utxoAddress = mockAddress + , utxoValue = + valueFromList + [ (GYLovelace, 100_000_000) + , (mockAssetA, 100) + , (mockAssetEmptyName, 1000) + ] + , utxoOutDatum = GYOutDatumNone + , utxoRefScript = Nothing + } + res = + utxoFromMaestro $ + mockMaestroUtxo + [ maestroAssetFromLovelace 100_000_000 + , maestroAssetSingleton mockAssetA 100 + , maestroAssetSingleton mockAssetEmptyName 1000 + ] + Nothing + Nothing + res @?= expected + , testCase "Datum Hash" $ do + let expected = + Right + GYUTxO + { utxoRef = mockTxOutRef + , utxoAddress = mockAddress + , utxoValue = valueFromList [] + , utxoOutDatum = GYOutDatumHash (fromJust $ datumHashFromHex $ Text.unpack mockDatumHashHex) + , utxoRefScript = Nothing + } + res = utxoFromMaestro $ mockMaestroUtxo [] (Just maestroDatumHash) Nothing + res @?= expected + , testCase "Datum Inline" $ do + let expected = + Right + GYUTxO + { utxoRef = mockTxOutRef + , utxoAddress = mockAddress + , utxoValue = valueFromList [] + , utxoOutDatum = GYOutDatumInline $ datumFromApi' $ either (error "Unable to read mock datum") id $ Api.scriptDataFromJson Api.ScriptDataJsonDetailedSchema mockScriptDataDetailed + , utxoRefScript = Nothing + } + res = utxoFromMaestro $ mockMaestroUtxo [] (Just maestroInlineDatum) Nothing + res @?= expected + , testCase "Ref Script" $ do + let expected = + Right + GYUTxO + { utxoRef = mockTxOutRef + , utxoAddress = mockAddress + , utxoValue = valueFromList [] + , utxoOutDatum = GYOutDatumNone + , utxoRefScript = GYPlutusScript <$> scriptFromCBOR @'PlutusV2 mockScriptCBOR + } + res = utxoFromMaestro $ mockMaestroUtxo [] Nothing (Just mockMaestroScript) + res @?= expected + ] + ] where getQueryUtxo :: Text.Text -> IO GYQueryUTxO getQueryUtxo pToken = maestroQueryUtxo <$> networkIdToMaestroEnv pToken netId getUTxOsAtAddress :: GYAddress -> Text.Text -> IO (Api.UTxO ApiEra) getUTxOsAtAddress addr pToken = do - queryUtxo <- getQueryUtxo pToken - utxos <- gyQueryUtxosAtAddress' queryUtxo addr Nothing - return $ utxosToApi utxos + queryUtxo <- getQueryUtxo pToken + utxos <- gyQueryUtxosAtAddress' queryUtxo addr Nothing + return $ utxosToApi utxos getUTxOsAtAddresses :: [GYAddress] -> Text.Text -> IO (Api.UTxO ApiEra) getUTxOsAtAddresses addrs pToken = do - queryUtxo <- getQueryUtxo pToken - utxos <- gyQueryUtxosAtAddresses' queryUtxo addrs - return $ utxosToApi utxos + queryUtxo <- getQueryUtxo pToken + utxos <- gyQueryUtxosAtAddresses' queryUtxo addrs + return $ utxosToApi utxos getUTxOAtRef :: GYTxOutRef -> Text.Text -> IO (Api.UTxO ApiEra) getUTxOAtRef ref pToken = do - queryUtxo <- getQueryUtxo pToken - utxo <- gyQueryUtxoAtTxOutRef' queryUtxo ref - return $ utxosToApi $ utxosFromList [fromJust utxo] + queryUtxo <- getQueryUtxo pToken + utxo <- gyQueryUtxoAtTxOutRef' queryUtxo ref + return $ utxosToApi $ utxosFromList [fromJust utxo] getUTxOsRefsAtAddress :: GYAddress -> Text.Text -> IO [GYTxOutRef] getUTxOsRefsAtAddress addr pToken = do - queryUtxo <- getQueryUtxo pToken - gyQueryUtxoRefsAtAddress' queryUtxo addr + queryUtxo <- getQueryUtxo pToken + gyQueryUtxoRefsAtAddress' queryUtxo addr getFileRefs :: String -> IO [GYTxOutRef] getFileRefs fileName = do - json <- BS.readFile fileName - let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) - refs = utxosRefs $ utxosFromApi utxos - return refs + json <- BS.readFile fileName + let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) + refs = utxosRefs $ utxosFromApi utxos + return refs getFileUTxOs :: String -> IO (Api.UTxO ApiEra) getFileUTxOs fileName = do - json <- BS.readFile fileName - let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) - return utxos + json <- BS.readFile fileName + let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) + return utxos compareUTxOs :: Api.UTxO ApiEra -> Api.UTxO ApiEra -> IO (Maybe String) compareUTxOs utxosFile utxosQuery = do - let utxosFileMap = Api.unUTxO utxosFile - utxosQueryMap = Api.unUTxO utxosQuery - return $ if Map.isSubmapOf utxosFileMap utxosQueryMap - then Nothing - else Just $ show (Map.difference utxosFileMap utxosQueryMap) + let utxosFileMap = Api.unUTxO utxosFile + utxosQueryMap = Api.unUTxO utxosQuery + return $ + if Map.isSubmapOf utxosFileMap utxosQueryMap + then Nothing + else Just $ show (Map.difference utxosFileMap utxosQueryMap) compareRefs :: [GYTxOutRef] -> [GYTxOutRef] -> IO (Maybe String) compareRefs refsFile refsQuery = do - let refSetQuery = Set.fromList refsQuery - refSetFile = Set.fromList refsFile - return $ if Set.isSubsetOf refSetFile refSetQuery - then Nothing - else Just $ show (Set.difference refSetFile refSetQuery) - - updateGolden :: Show a => a -> IO () + let refSetQuery = Set.fromList refsQuery + refSetFile = Set.fromList refsFile + return $ + if Set.isSubsetOf refSetFile refSetQuery + then Nothing + else Just $ show (Set.difference refSetFile refSetQuery) + + updateGolden :: (Show a) => a -> IO () updateGolden = error . show goldenTestUtxos :: TestName -> IO (Api.UTxO ApiEra) -> IO (Api.UTxO ApiEra) -> TestTree goldenTestUtxos name queryData getFileData = - goldenTest name queryData getFileData compareUTxOs updateGolden + goldenTest name queryData getFileData compareUTxOs updateGolden goldenTestRefs :: TestName -> IO [GYTxOutRef] -> IO [GYTxOutRef] -> TestTree goldenTestRefs name queryData getFileData = - goldenTest name queryData getFileData compareRefs updateGolden + goldenTest name queryData getFileData compareRefs updateGolden ------------------------------------------------------------------------------- -- Mock Values @@ -231,15 +287,16 @@ mockQueryTxIx :: Word mockQueryTxIx = 0 mockMaestroUtxo :: [Maestro.Asset] -> Maybe Maestro.DatumOption -> Maybe Maestro.Script -> Maestro.UtxoWithBytes -mockMaestroUtxo assets mDat mRefScript = Maestro.UtxoWithBytes - { utxoWithBytesTxHash = mockTxId - , utxoWithBytesIndex = mockTxIx - , utxoWithBytesAssets = assets - , utxoWithBytesAddress = mockAddressB32 - , utxoWithBytesDatum = mDat - , utxoWithBytesReferenceScript = mRefScript - , utxoWithBytesTxoutCbor = Nothing - } +mockMaestroUtxo assets mDat mRefScript = + Maestro.UtxoWithBytes + { utxoWithBytesTxHash = mockTxId + , utxoWithBytesIndex = mockTxIx + , utxoWithBytesAssets = assets + , utxoWithBytesAddress = mockAddressB32 + , utxoWithBytesDatum = mDat + , utxoWithBytesReferenceScript = mRefScript + , utxoWithBytesTxoutCbor = Nothing + } mockTxId :: Maestro.TxHash mockTxId = "4293386fef391299c9886dc0ef3e8676cbdbc2c9f2773507f1f838e00043a189" @@ -257,20 +314,22 @@ mockAddress :: GYAddress mockAddress = unsafeAddressFromText $ coerce mockAddressB32 maestroDatumHash :: Maestro.DatumOption -maestroDatumHash = Maestro.DatumOption - { datumOptionType = Maestro.Hash - , datumOptionHash = mockDatumHashHex - , datumOptionBytes = Nothing - , datumOptionJson = Nothing - } +maestroDatumHash = + Maestro.DatumOption + { datumOptionType = Maestro.Hash + , datumOptionHash = mockDatumHashHex + , datumOptionBytes = Nothing + , datumOptionJson = Nothing + } maestroInlineDatum :: Maestro.DatumOption -maestroInlineDatum = Maestro.DatumOption - { datumOptionType = Maestro.Inline - , datumOptionHash = mockDatumHashHex - , datumOptionBytes = Just mockDatumBtyes - , datumOptionJson = Just mockScriptDataDetailed - } +maestroInlineDatum = + Maestro.DatumOption + { datumOptionType = Maestro.Inline + , datumOptionHash = mockDatumHashHex + , datumOptionBytes = Just mockDatumBtyes + , datumOptionJson = Just mockScriptDataDetailed + } mockDatumBtyes :: Text.Text mockDatumBtyes = "d8799fd8799f1830ffff" @@ -282,19 +341,23 @@ mockScriptDataDetailed :: Aeson.Value mockScriptDataDetailed = fromJust $ Aeson.decode "{\"fields\": [{\"fields\": [{\"int\": 48}],\"constructor\": 0}],\"constructor\": 0}" maestroAssetFromLovelace :: Integer -> Maestro.Asset -maestroAssetFromLovelace n = Maestro.Asset { assetAmount = fromIntegral n - , assetUnit = Maestro.Lovelace - } +maestroAssetFromLovelace n = + Maestro.Asset + { assetAmount = fromIntegral n + , assetUnit = Maestro.Lovelace + } maestroAssetSingleton :: GYAssetClass -> Integer -> Maestro.Asset -maestroAssetSingleton GYLovelace n = Maestro.Asset - { assetAmount = fromIntegral n - , assetUnit = Maestro.Lovelace - } -maestroAssetSingleton (GYToken policyId tokenName) n = Maestro.Asset - { assetAmount = fromIntegral n - , assetUnit = Maestro.UserMintedToken (Maestro.NonAdaNativeToken (coerce $ mintingPolicyIdToText policyId) (coerce $ tokenNameToHex tokenName)) - } +maestroAssetSingleton GYLovelace n = + Maestro.Asset + { assetAmount = fromIntegral n + , assetUnit = Maestro.Lovelace + } +maestroAssetSingleton (GYToken policyId tokenName) n = + Maestro.Asset + { assetAmount = fromIntegral n + , assetUnit = Maestro.UserMintedToken (Maestro.NonAdaNativeToken (coerce $ mintingPolicyIdToText policyId) (coerce $ tokenNameToHex tokenName)) + } mockAssetA :: GYAssetClass mockAssetA = GYToken "005eaf690cba88f441494e42f5edce9bd7f595c56f99687e2fa0aad4" "A" @@ -303,12 +366,13 @@ mockAssetEmptyName :: GYAssetClass mockAssetEmptyName = GYToken "005eaf690cba88f441494e42f5edce9bd7f595c56f99687e2fa0bbd4" "" mockMaestroScript :: Maestro.Script -mockMaestroScript = Maestro.Script - { scriptType = Maestro.PlutusV2 - , scriptHash = "90dbacba2758d72a3e0d75c56fbe393da91cc474a4bffbb59c3baeb6" - , scriptBytes = Just mockScriptCBOR - , scriptJson = Nothing - } +mockMaestroScript = + Maestro.Script + { scriptType = Maestro.PlutusV2 + , scriptHash = "90dbacba2758d72a3e0d75c56fbe393da91cc474a4bffbb59c3baeb6" + , scriptBytes = Just mockScriptCBOR + , scriptJson = Nothing + } mockScriptCBOR :: Text.Text mockScriptCBOR = "5910fe010000332323232323232323232323232323322323232322232232322323253353330093333573466e1cd55cea803a4000464646666ae68cdc39aab9d5001480008dd69aba135573ca004464c6a66ae7007c0780740704dd50009aba135573ca010464c6a66ae7007006c068064cccd5cd19b875004480188488880108cccd5cd19b875005480108c848888c004014ccd54069d73ae357426aae79401c8cccd5cd19b8750064800884888800c8cccd5cd19b875007480008488880088c98d4cd5ce00f80f00e80e00d80d00c9999ab9a3370e6aae754009200023322123300100300232323232323232323232323333573466e1cd55cea8052400046666666666444444444424666666666600201601401201000e00c00a00800600466a02e464646666ae68cdc39aab9d5002480008cc8848cc00400c008c088d5d0a801180e1aba135744a004464c6a66ae700b00ac0a80a44d55cf280089baa00135742a01466a02e0306ae854024ccd54069d7280c9aba150083335501a75ca0326ae85401ccd405c088d5d0a80319a80b99aa812811bad35742a00a6464646666ae68cdc39aab9d5002480008cc8848cc00400c008c8c8c8cccd5cd19b8735573aa004900011991091980080180119a8143ad35742a00460526ae84d5d1280111931a99ab9c03002f02e02d135573ca00226ea8004d5d0a8011919191999ab9a3370e6aae754009200023322123300100300233502875a6ae854008c0a4d5d09aba2500223263533573806005e05c05a26aae7940044dd50009aba135744a004464c6a66ae700b00ac0a80a44d55cf280089baa00135742a00866a02eeb8d5d0a80199a80b99aa812bae200135742a004603e6ae84d5d1280111931a99ab9c028027026025135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135573ca00226ea8004d5d0a8011919191999ab9a3370ea0029003119091111802002980d1aba135573ca00646666ae68cdc3a8012400846424444600400a60386ae84d55cf280211999ab9a3370ea0069001119091111800802980c1aba135573ca00a46666ae68cdc3a8022400046424444600600a6eb8d5d09aab9e500623263533573804604404204003e03c03a26aae7540044dd50009aba135744a004464c6a66ae7007006c06806440684c98d4cd5ce2481035054350001a019135573ca00226ea80044d55cea80089baa001137540022464460046eb0004c8004d5405088cccd55cf80092804919a80418021aba100230033574400402646464646666ae68cdc39aab9d5003480008ccc88848ccc00401000c008c8c8c8cccd5cd19b8735573aa0049000119910919800801801180a9aba1500233500e014357426ae8940088c98d4cd5ce00c80c00b80b09aab9e5001137540026ae85400cccd5401dd728031aba1500233500a75c6ae84d5d1280111931a99ab9c015014013012135744a00226aae7940044dd5000899aa800bae75a224464460046eac004c8004d5404888c8cccd55cf80112804119a80399aa80a98031aab9d5002300535573ca00460086ae8800c0484d5d080088910010910911980080200189119191999ab9a3370ea0029000119091180100198029aba135573ca00646666ae68cdc3a801240044244002464c6a66ae7004404003c0380344d55cea80089baa001232323333573466e1cd55cea80124000466442466002006004600a6ae854008dd69aba135744a004464c6a66ae7003803403002c4d55cf280089baa0012323333573466e1cd55cea800a400046eb8d5d09aab9e500223263533573801801601401226ea8004488c8c8cccd5cd19b87500148010848880048cccd5cd19b875002480088c84888c00c010c018d5d09aab9e500423333573466e1d400d20002122200223263533573801e01c01a01801601426aae7540044dd50009191999ab9a3370ea0029001109100111999ab9a3370ea0049000109100091931a99ab9c00b00a009008007135573a6ea80048c8c8c8c8c8cccd5cd19b8750014803084888888800c8cccd5cd19b875002480288488888880108cccd5cd19b875003480208cc8848888888cc004024020dd71aba15005375a6ae84d5d1280291999ab9a3370ea00890031199109111111198010048041bae35742a00e6eb8d5d09aba2500723333573466e1d40152004233221222222233006009008300c35742a0126eb8d5d09aba2500923333573466e1d40192002232122222223007008300d357426aae79402c8cccd5cd19b875007480008c848888888c014020c038d5d09aab9e500c23263533573802602402202001e01c01a01801601426aae7540104d55cf280189aab9e5002135573ca00226ea80048c8c8c8c8cccd5cd19b875001480088ccc888488ccc00401401000cdd69aba15004375a6ae85400cdd69aba135744a00646666ae68cdc3a80124000464244600400660106ae84d55cf280311931a99ab9c00c00b00a009008135573aa00626ae8940044d55cf280089baa001232323333573466e1d400520022321223001003375c6ae84d55cf280191999ab9a3370ea004900011909118010019bae357426aae7940108c98d4cd5ce00480400380300289aab9d5001137540022244464646666ae68cdc39aab9d5002480008cd54028c018d5d0a80118029aba135744a004464c6a66ae7002402001c0184d55cf280089baa0014984800524103505431001122123300100300211232300100122330033002002001332323322332232323232332232323232323232323232323232323232332232323232323232323232222232323232323253333500815335333573466e1ccdc3004a400890010170168817099ab9c49011c5374617465206e6f742076616c696420666f7220636c6f73696e672e0002d15335300d0072135001223500122253353330170120023550082220021500715335335738920115496e76616c6964206f75747075742076616c75652e0003315007103313562615335300d00721350012235001222533533301701200235500a222002150091533533573892115496e76616c6964206f75747075742076616c75652e00033150091033135626232323232153353232325335333573466e20044cdc0000a400806a06c2a0042a66a666ae68cdc480899b81001480100d80d45400840d4d4044880044ccd5cd19b883322333355002323350272233350250030010023502200133502622230033002001200122337000029001000a4000603c2400266062a06c002900301a019a8058a8008a99a99ab9c491225374617465206e6f742076616c696420666f72206d696e74696e67207072697a652e000321500110321533533301501032323355301d1200123500122335503a002335530201200123500122335503d00233350012330374800000488cc0e00080048cc0dc0052000001330180020015004500a355009222002150011533533573892115496e76616c6964206f75747075742076616c75652e0003115001103115335333573466e1c030d540208894cd400484d4038894cd4cc06000c008854cd4c0a400484004540cc540c8540bc0c40c05400454cd4cd5ce248115496e76616c6964206f75747075742073746174652e000301500110301533533301300e500135009223500222222222220071030133573892011e546865207072697a65206973206e6f74206265696e67206d696e7465642e0002f13500122335032335503400233503233550340014800940cd40cc54cd4ccd5cd19b8753333500710081337020109001099b800084800884024d540048894cd400484d4028894cd4cc05000c008854cd4c09400484004540a4540a0540940b40b040b44cd5ce248115496e76616c6964206f75747075742073746174652e0002c153353009005130204988854cd40044008884c0912615335333573466e1d4cccd401440184cdc080324004266e00019200221007355001222533500121350082253353301200300221533530230012100115029150281502502b02a102b133573892115496e76616c6964206f75747075742073746174652e0002a153353007003130204988854cd40044008884c09126153353006002130214988854cd40044008884c09526153353007001213500122350012220021356262350012235002222222222253353301000a00b2135001223500122233355301c12001223500222235008223500522325335335005233500425335333573466e3c0080041081045400c410481048cd4010810494cd4ccd5cd19b8f002001042041150031041133504100a0091009153350032153350022133500223350022335002233500223303200200120442335002204423303200200122204422233500420442225335333573466e1c01800c11c11854cd4ccd5cd19b8700500204704613302500400110461046103f153350012103f103f503800f132635335738921024c660002302222333573466e1c00800409008c8d400488d40088888888888cc03802802c88cccd40049407094070940708ccd54c0344800540148d4004894cd54cd4ccd5cd19b8f350022200235004220020260251333573466e1cd400888004d40108800409809440944d408000c5407c00c88d400488888888894cd4ccd54c0544800540348d4004894cd4ccd5cd19b8f00200f02e02d135028003150270022135026350012200115024133500e225335002210031001501722233355300a120013500f500e2350012233355300d1200135012501123500122333500123300a4800000488cc02c0080048cc028005200000133004002001223355300712001235001223355024002333500123355300b1200123500122335502800235500d0010012233355500801000200123355300b1200123500122335502800235500c00100133355500300b00200111122233355300412001501f335530071200123500122335502400235500900133355300412001223500222533533355300c1200132335013223335003220020020013500122001123300122533500210251001022235001223300a002005006100313350230040035020001335530071200123500122323355025003300100532001355025225335001135500a003221350022253353300c002008112223300200a004130060030023200135501e221122253350011002221330050023335530071200100500400111212223003004112122230010043200135501b22112253350011501d22133501e300400233553006120010040013200135501a22112225335001135006003221333500900530040023335530071200100500400112350012200112350012200222333573466e3c008004054050448cc004894cd40084004405004c48cd400888ccd400c88008008004d40048800448848cc00400c0088c8c8ccccccd5d200191999ab9a3370e6aae75400d2000233335573ea0064a01c46666aae7cd5d128021299a9919191999999aba400323333573466e1cd55cea801a400046666aae7d400c940548cccd55cf9aba250042533532333333357480024a0304a0304a03046a0326eb400894060044d5d0a802909a80c0008a80b1280b0078071280a0061280992809928099280980609aab9e5001137540026ae85401484d40440045403c9403c02001c94034014940309403094030940300144d55cf280089baa001498480048d58984d58988d58984d58988d589848488c00800c44880044d589888cdc0001000990009aa803911299a80088011109a8011119803999804001003000801990009aa8031111299a80088011109a80111299a999ab9a3370e00290000050048999804003803001899980400399a80589199800804001801003001891001091000889100109109119800802001889109198008018010891918008009119801980100100099a89119a8911980119aa80224411c725ba16e744abf2074c951c320fcc92ea0158ed7bb325b092a58245d00488100481508848cc00400c0088004448848cc00400c0084480041" diff --git a/tests/GeniusYield/Test/Providers/Mashup.hs b/tests/GeniusYield/Test/Providers/Mashup.hs index b5e2e90a..5c9cefa9 100644 --- a/tests/GeniusYield/Test/Providers/Mashup.hs +++ b/tests/GeniusYield/Test/Providers/Mashup.hs @@ -1,45 +1,51 @@ -module GeniusYield.Test.Providers.Mashup - ( providersMashupTests - ) where +module GeniusYield.Test.Providers.Mashup ( + providersMashupTests, +) where -import Control.Concurrent (threadDelay) -import Control.Exception (handle) -import Data.Default (def) -import Data.List (isInfixOf) -import Data.Maybe (fromJust) -import qualified Data.Set as Set (difference, fromList) -import GeniusYield.CardanoApi.EraHistory (extractEraSummaries) -import GeniusYield.GYConfig -import GeniusYield.Imports -import GeniusYield.Providers.Common (SubmitTxException, - datumFromCBOR) -import GeniusYield.TxBuilder -import GeniusYield.Types -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertBool, assertFailure, - testCase) +import Control.Concurrent (threadDelay) +import Control.Exception (handle) +import Data.Default (def) +import Data.List (isInfixOf) +import Data.Maybe (fromJust) +import Data.Set qualified as Set (difference, fromList) +import GeniusYield.CardanoApi.EraHistory (extractEraSummaries) +import GeniusYield.GYConfig +import GeniusYield.Imports +import GeniusYield.Providers.Common ( + SubmitTxException, + datumFromCBOR, + ) +import GeniusYield.TxBuilder +import GeniusYield.Types +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ( + assertBool, + assertFailure, + testCase, + ) providersMashupTests :: [GYCoreConfig] -> TestTree providersMashupTests configs = - testGroup "Providers Mashup" + testGroup + "Providers Mashup" [ testCase "Datum lookup - GYLookupDatum" $ do delayBySecond - dats <- forM configs $ \config -> withCfgProviders config mempty $ \GYProviders {..} -> fromJust <$> gyLookupDatum "a7ed3e81ef2e98a85c8d5649ed6344b7f7b36a31103ab18395ef4e80b8cac565" -- A datum hash seen at always fail script's address. + dats <- forM configs $ \config -> withCfgProviders config mempty $ \GYProviders {..} -> fromJust <$> gyLookupDatum "a7ed3e81ef2e98a85c8d5649ed6344b7f7b36a31103ab18395ef4e80b8cac565" -- A datum hash seen at always fail script's address. assertBool "Datums are not all equal" $ allEqual dats , testCase "Parameters" $ do paramsList <- forM configs $ \config -> withCfgProviders config mempty $ \provider -> do - delayBySecond - pp <- gyGetProtocolParameters provider - delayBySecond - ss <- gyGetSystemStart provider - delayBySecond - eraHist <- extractEraSummaries <$> gyGetEraHistory provider - delayBySecond - -- TODO: There is a bug in Maestro due to which it returns extra pools. Thus, this is ignored for now. - _sp <- gyGetStakePools provider - delayBySecond - slotConfig' <- gyGetSlotConfig provider - pure (pp, eraHist, ss, slotConfig') + delayBySecond + pp <- gyGetProtocolParameters provider + delayBySecond + ss <- gyGetSystemStart provider + delayBySecond + eraHist <- extractEraSummaries <$> gyGetEraHistory provider + delayBySecond + -- TODO: There is a bug in Maestro due to which it returns extra pools. Thus, this is ignored for now. + _sp <- gyGetStakePools provider + delayBySecond + slotConfig' <- gyGetSlotConfig provider + pure (pp, eraHist, ss, slotConfig') assertBool "Parameters are not all equal" $ allEqual paramsList , testCase "Stake address info" $ do saInfos <- forM configs $ \config -> withCfgProviders config mempty $ \GYProviders {..} -> do @@ -48,16 +54,16 @@ providersMashupTests configs = assertBool "Stake address info are not all equal" $ allEqual saInfos , testCase "Query UTxOs" $ do let - -- Blockfrost is unable to get the preimage of the involved datum hash, thus it's being deleted for in our set so that test still passes. - utxoBug1 = (GYUTxO {utxoRef = "6d2174d3956d8eb2b3e1e198e817ccf1332a599d5d7320400bfd820490d706be#0", utxoAddress = unsafeAddressFromText "addr_test1wpgexmeunzsykesf42d4eqet5yvzeap6trjnflxqtkcf66g0kpnxt", utxoValue = valueFromList [(GYLovelace,50000000)], utxoOutDatum = GYOutDatumHash "15461aa490b224fe541f3568e5d7704e0d88460cde9f418f700e2b6864d8d3c9", utxoRefScript = Nothing},Just (either (error "absurd - Mashup: parsing datum failed") id $ datumFromCBOR "19077a")) - utxoBug2 = (GYUTxO {utxoRef = "6d2174d3956d8eb2b3e1e198e817ccf1332a599d5d7320400bfd820490d706be#0", utxoAddress = unsafeAddressFromText "addr_test1wpgexmeunzsykesf42d4eqet5yvzeap6trjnflxqtkcf66g0kpnxt", utxoValue = valueFromList [(GYLovelace,50000000)], utxoOutDatum = GYOutDatumHash "15461aa490b224fe541f3568e5d7704e0d88460cde9f418f700e2b6864d8d3c9", utxoRefScript = Nothing}, Nothing) - utxoBugSet = Set.fromList [utxoBug1, utxoBug2] + -- Blockfrost is unable to get the preimage of the involved datum hash, thus it's being deleted for in our set so that test still passes. + utxoBug1 = (GYUTxO {utxoRef = "6d2174d3956d8eb2b3e1e198e817ccf1332a599d5d7320400bfd820490d706be#0", utxoAddress = unsafeAddressFromText "addr_test1wpgexmeunzsykesf42d4eqet5yvzeap6trjnflxqtkcf66g0kpnxt", utxoValue = valueFromList [(GYLovelace, 50000000)], utxoOutDatum = GYOutDatumHash "15461aa490b224fe541f3568e5d7704e0d88460cde9f418f700e2b6864d8d3c9", utxoRefScript = Nothing}, Just (either (error "absurd - Mashup: parsing datum failed") id $ datumFromCBOR "19077a")) + utxoBug2 = (GYUTxO {utxoRef = "6d2174d3956d8eb2b3e1e198e817ccf1332a599d5d7320400bfd820490d706be#0", utxoAddress = unsafeAddressFromText "addr_test1wpgexmeunzsykesf42d4eqet5yvzeap6trjnflxqtkcf66g0kpnxt", utxoValue = valueFromList [(GYLovelace, 50000000)], utxoOutDatum = GYOutDatumHash "15461aa490b224fe541f3568e5d7704e0d88460cde9f418f700e2b6864d8d3c9", utxoRefScript = Nothing}, Nothing) + utxoBugSet = Set.fromList [utxoBug1, utxoBug2] utxosProviders <- forM configs $ \config -> withCfgProviders config mempty $ \provider -> do let alwaysFailAddress = unsafeAddressFromText "addr_test1wpgexmeunzsykesf42d4eqet5yvzeap6trjnflxqtkcf66g0kpnxt" - alwaysFailCredential = GYPaymentCredentialByScript "51936f3c98a04b6609aa9b5c832ba1182cf43a58e534fcc05db09d69" -- Credential of always fail script address. + alwaysFailCredential = GYPaymentCredentialByScript "51936f3c98a04b6609aa9b5c832ba1182cf43a58e534fcc05db09d69" -- Credential of always fail script address. ciWalletAddress = unsafeAddressFromText "addr_test1vqrlk2mckwgh60mtlga9nhnp70pztjls64ty589ud7tdd6ckynfpg" - ciWalletCredential = GYPaymentCredentialByKey "07fb2b78b3917d3f6bfa3a59de61f3c225cbf0d5564a1cbc6f96d6eb" -- Could ofc be derived from address. - myAddrList = [alwaysFailAddress, ciWalletAddress] -- always fail script's address. It has all the cases, reference scripts, inline datums, many UTxOs, etc. Besides it, CI wallet's address is also included. + ciWalletCredential = GYPaymentCredentialByKey "07fb2b78b3917d3f6bfa3a59de61f3c225cbf0d5564a1cbc6f96d6eb" -- Could ofc be derived from address. + myAddrList = [alwaysFailAddress, ciWalletAddress] -- always fail script's address. It has all the cases, reference scripts, inline datums, many UTxOs, etc. Besides it, CI wallet's address is also included. myCredList = [alwaysFailCredential, ciWalletCredential] delayBySecond utxosAtAddresses' <- gyQueryUtxosAtAddresses provider myAddrList @@ -66,9 +72,9 @@ providersMashupTests configs = -- All the below refs were taken from always fail address. let refWithDatumHash = "dc1c7958f94b7a458dffa224d18b5b8464f81f6360913c26eca4199f67ac6435#1" outputRefs = - [ "930de0fd6718fc87cd99be663f1b1dd099cad6cec3dede49d82b3554a1e8eb86#0" -- Contains reference script. - , refWithDatumHash -- Contains datum hash. - , "930de0fd6718fc87cd99be663f1b1dd099cad6cec3dede49d82b3554a1e8eb86#0" -- Contains inline datum. + [ "930de0fd6718fc87cd99be663f1b1dd099cad6cec3dede49d82b3554a1e8eb86#0" -- Contains reference script. + , refWithDatumHash -- Contains datum hash. + , "930de0fd6718fc87cd99be663f1b1dd099cad6cec3dede49d82b3554a1e8eb86#0" -- Contains inline datum. ] delayBySecond utxosAtRefs <- gyQueryUtxosAtTxOutRefs provider outputRefs @@ -87,7 +93,7 @@ providersMashupTests configs = delayBySecond utxosAtScriptCredentialWithDatums <- runGYTxQueryMonadIO (cfgNetworkId config) provider $ utxosAtPaymentCredentialWithDatums alwaysFailCredential Nothing delayBySecond - utxosAtScriptAddressWithAsset <- gyQueryUtxosAtAddress provider alwaysFailAddress (Just "6d24161a60592755dcbcc2c1330bbe968f913acc15ec40f0be3873ee.61757468") -- An asset I saw by random chance. + utxosAtScriptAddressWithAsset <- gyQueryUtxosAtAddress provider alwaysFailAddress (Just "6d24161a60592755dcbcc2c1330bbe968f913acc15ec40f0be3873ee.61757468") -- An asset I saw by random chance. -- TODO: Write variant of above for with datums. delayBySecond utxosAtPaymentCredentials' <- gyQueryUtxosAtPaymentCredentials provider myCredList @@ -96,19 +102,32 @@ providersMashupTests configs = -- Following is commented out due to an apparent bug in Blockfrost. -- delayBySecond -- utxosAtScriptAddressWithAssetAndDatums <- gyQueryUtxosAtAddressWithDatums provider (unsafeAddressFromText "addr_test1wz2mzj532enpgu5vgwxuh249fpknx5ft9wxse2876z0mp2q89ye7k") (Just "c6e65ba7878b2f8ea0ad39287d3e2fd256dc5c4160fc19bdf4c4d87e.7447454e53") - pure (utxosAtAddresses', Set.fromList utxosAtAddressesWithDatums' `Set.difference` utxoBugSet, utxosAtRefs, Set.fromList utxoRefsAtAddress', Set.fromList utxosAtRefsWithDatums', utxoAtRefWithDatum', utxosAtScriptCredential <> utxosAtKeyCredential, Set.fromList utxosAtScriptCredentialWithDatums `Set.difference` utxoBugSet, utxosAtScriptAddressWithAsset, utxosAtScriptCredentialWithAsset, utxosAtPaymentCredentials', Set.fromList utxosAtPaymentCredentialsWithDatums' `Set.difference` utxoBugSet - -- , Set.fromList utxosAtScriptAddressWithAssetAndDatums - ) + pure + ( utxosAtAddresses' + , Set.fromList utxosAtAddressesWithDatums' `Set.difference` utxoBugSet + , utxosAtRefs + , Set.fromList utxoRefsAtAddress' + , Set.fromList utxosAtRefsWithDatums' + , utxoAtRefWithDatum' + , utxosAtScriptCredential <> utxosAtKeyCredential + , Set.fromList utxosAtScriptCredentialWithDatums `Set.difference` utxoBugSet + , utxosAtScriptAddressWithAsset + , utxosAtScriptCredentialWithAsset + , utxosAtPaymentCredentials' + , Set.fromList utxosAtPaymentCredentialsWithDatums' `Set.difference` utxoBugSet + -- , Set.fromList utxosAtScriptAddressWithAssetAndDatums + ) assertBool "Utxos are not all equal" $ allEqual utxosProviders , testCase "Checking presence of error message when submitting an invalid transaction" $ do let - handler :: SubmitTxException -> IO GYTxId - handler e = - let errorText = show e - in ( if "BadInputsUTxO" `isInfixOf` errorText then - pure "6c751d3e198c5608dfafdfdffe16aeac8a28f88f3a769cf22dd45e8bc84f47e8" -- Any transaction ID. - else error $ "Not satisfied, error text: " <> errorText - ) + handler :: SubmitTxException -> IO GYTxId + handler e = + let errorText = show e + in ( if "BadInputsUTxO" `isInfixOf` errorText + then + pure "6c751d3e198c5608dfafdfdffe16aeac8a28f88f3a769cf22dd45e8bc84f47e8" -- Any transaction ID. + else error $ "Not satisfied, error text: " <> errorText + ) forM_ configs $ \config -> withCfgProviders config mempty $ \GYProviders {..} -> do delayBySecond handle handler $ gySubmitTx . fromRight (error "absurd") $ txFromHexBS "84a30083825820cd1fd0900870f19cba004ad73996d5f01f22790c7e2efcd46b7d1bacbf97ca6d00825820cd1fd0900870f19cba004ad73996d5f01f22790c7e2efcd46b7d1bacbf97ca6d01825820cd1fd0900870f19cba004ad73996d5f01f22790c7e2efcd46b7d1bacbf97ca6d020183a200581d6007fb2b78b3917d3f6bfa3a59de61f3c225cbf0d5564a1cbc6f96d6eb011a3b3b81d5a200581d6007fb2b78b3917d3f6bfa3a59de61f3c225cbf0d5564a1cbc6f96d6eb011a002dc6c0a200581d6007fb2b78b3917d3f6bfa3a59de61f3c225cbf0d5564a1cbc6f96d6eb011a001bc75b021a0002bd25a10081825820b8ee2dc03ba6f88baa7e4430675df3e559d63a1282f7763de71227041e351023584020313e571def2f09145ae6b0eb26e99260d14885789929a354fea4a585d5f053fc2eae86d36f484269b0d95a25abb7acc3b15033565d00afd83af83f24d9be0ef5f6" @@ -121,28 +140,28 @@ providersMashupTests configs = senderUTxOs <- runGYTxQueryMonadIO nid provider $ utxosAtAddress senderAddress Nothing delayBySecond let totalSenderFunds = foldMapUTxOs utxoValue senderUTxOs - valueToSend = totalSenderFunds `valueMinus` valueFromLovelace 5_000_000 - -- This way, UTxO distribution in test wallet should remain same. + valueToSend = totalSenderFunds `valueMinus` valueFromLovelace 5_000_000 + -- This way, UTxO distribution in test wallet should remain same. txBody <- runGYTxBuilderMonadIO nid provider [senderAddress] senderAddress Nothing $ buildTxBody $ mustHaveOutput $ mkGYTxOutNoDatum @'PlutusV2 senderAddress valueToSend delayBySecond let signedTxBody = signGYTxBody txBody [skey] printf "Signed tx: %s\n" (txToHex signedTxBody) - tid <- gySubmitTx signedTxBody + tid <- gySubmitTx signedTxBody printf "Submitted tx: %s\n" tid gyAwaitTxConfirmed (GYAwaitTxParameters {maxAttempts = 20, confirmations = 1, checkInterval = 10_000_000}) tid , testCase "Await Tx Confirmed - Submitted Tx" $ forM_ configs $ \config -> withCfgProviders config mempty $ - \GYProviders {..} -> gyAwaitTxConfirmed def "c67b57d63e846c6dc17f0c2647893d5f7376690cde62b8b392ecfcb75a4697e2" -- A transaction id which generated UTxO at the always fail address. Thus it is guaranteed to be always there (unless of course network is respun). + \GYProviders {..} -> gyAwaitTxConfirmed def "c67b57d63e846c6dc17f0c2647893d5f7376690cde62b8b392ecfcb75a4697e2" -- A transaction id which generated UTxO at the always fail address. Thus it is guaranteed to be always there (unless of course network is respun). , testCase "Await Tx Confirmed - Timeout for non-existing Tx" $ do let handleAwaitTxException (GYAwaitTxException _) = return () forM_ configs $ \config -> withCfgProviders config mempty $ \GYProviders {..} -> handle handleAwaitTxException $ do - gyAwaitTxConfirmed def{maxAttempts = 2, checkInterval = 1_000_000} "9b50152cc5cfca6a842f32b1e886a3ffdc1a1704fa87a15a88837996b6a9df36" -- <-- A non-existing transaction id. - assertFailure "Exepected GYAwaitTxException to be raised" + gyAwaitTxConfirmed def {maxAttempts = 2, checkInterval = 1_000_000} "9b50152cc5cfca6a842f32b1e886a3ffdc1a1704fa87a15a88837996b6a9df36" -- <-- A non-existing transaction id. + assertFailure "Exepected GYAwaitTxException to be raised" ] where delayBySecond = threadDelay 1_000_000 -allEqual :: Eq a => [a] -> Bool -allEqual [] = True -allEqual (x:xs) = all (== x) xs +allEqual :: (Eq a) => [a] -> Bool +allEqual [] = True +allEqual (x : xs) = all (== x) xs diff --git a/tests/GeniusYield/Test/RefInput.hs b/tests/GeniusYield/Test/RefInput.hs index 9c929cc5..166c06aa 100644 --- a/tests/GeniusYield/Test/RefInput.hs +++ b/tests/GeniusYield/Test/RefInput.hs @@ -1,59 +1,66 @@ {-# LANGUAGE LambdaCase #-} + -- Test to signify correct functionality of reference inputs implementation. -- TODO: Atlas currently doesn't support referring to the uninlined datum of reference input. But if that support is added, tests can be written utilising it here. -{-| + +{- | Module : GeniusYield.Test.RefInput Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.com Stability : develop - -} -module GeniusYield.Test.RefInput - ( refInputTests - ) where +module GeniusYield.Test.RefInput ( + refInputTests, +) where -import Test.Tasty (TestTree, - testGroup) +import Test.Tasty ( + TestTree, + testGroup, + ) -import GeniusYield.Imports -import GeniusYield.HTTP.Errors -import GeniusYield.Test.Clb -import GeniusYield.Test.OnChain.GuessRefInputDatum.Compiled -import GeniusYield.Test.Utils -import GeniusYield.Transaction -import GeniusYield.TxBuilder -import GeniusYield.Types +import GeniusYield.HTTP.Errors +import GeniusYield.Imports +import GeniusYield.Test.Clb +import GeniusYield.Test.OnChain.GuessRefInputDatum.Compiled +import GeniusYield.Test.Utils +import GeniusYield.Transaction +import GeniusYield.TxBuilder +import GeniusYield.Types gyGuessRefInputDatumValidator :: GYValidator 'PlutusV2 gyGuessRefInputDatumValidator = validatorFromPlutus guessRefInputDatumValidator refInputTests :: TestTree -refInputTests = testGroup "Reference Input" +refInputTests = + testGroup + "Reference Input" [ mkTestFor "Inlined datum" $ refInputTrace True 5 5 . testWallets , mkTestFor "Inlined datum - Wrong guess" $ mustFail . refInputTrace True 5 4 . testWallets , mkTestFor "Reference input must not be consumed" $ - mustFailWith (\case { GYBuildTxException (GYBuildTxBalancingError (GYBalancingErrorInsufficientFunds _)) -> True; _ -> False }) - . tryRefInputConsume - . testWallets + mustFailWith (\case GYBuildTxException (GYBuildTxBalancingError (GYBalancingErrorInsufficientFunds _)) -> True; _ -> False) + . tryRefInputConsume + . testWallets ] -guessRefInputRun :: GYTxMonad m => GYTxOutRef -> GYTxOutRef -> Integer -> m () +guessRefInputRun :: (GYTxMonad m) => GYTxOutRef -> GYTxOutRef -> Integer -> m () guessRefInputRun refInputORef consumeRef guess = do let redeemer = Guess guess skeleton :: GYTxSkeleton 'PlutusV2 = - mustHaveInput GYTxIn - { gyTxInTxOutRef = consumeRef - , gyTxInWitness = GYTxInWitnessScript - (GYInScript gyGuessRefInputDatumValidator) - (datumFromPlutusData ()) - (redeemerFromPlutusData redeemer) - } <> - mustHaveRefInput refInputORef + mustHaveInput + GYTxIn + { gyTxInTxOutRef = consumeRef + , gyTxInWitness = + GYTxInWitnessScript + (GYInScript gyGuessRefInputDatumValidator) + (datumFromPlutusData ()) + (redeemerFromPlutusData redeemer) + } + <> mustHaveRefInput refInputORef buildTxBody skeleton >>= signAndSubmitConfirmed_ -refInputTrace :: GYTxGameMonad m => Bool -> Integer -> Integer -> Wallets -> m () -refInputTrace toInline actual guess Wallets{..} = do +refInputTrace :: (GYTxGameMonad m) => Bool -> Integer -> Integer -> Wallets -> m () +refInputTrace toInline actual guess Wallets {..} = do let myGuess :: Integer = guess outValue :: GYValue = valueFromLovelace 20_000_000 refInputORef <- asUser w1 $ addRefInput toInline (userAddr w9) (datumFromPlutusData (RefInputDatum actual)) @@ -65,25 +72,25 @@ refInputTrace toInline actual guess Wallets{..} = do txId <- submitTxConfirmed tx let mOrefIndices = findLockedUtxosInBody addr tx orefIndices <- maybe (throwAppError . someBackendError $ "Unable to get GYAddress from some Plutus.Address in txBody") return mOrefIndices - oref <- case fmap (txOutRefFromApiTxIdIx (txIdToApi txId) . wordToApiIx) orefIndices of - [oref'] -> return oref' + oref <- case fmap (txOutRefFromApiTxIdIx (txIdToApi txId) . wordToApiIx) orefIndices of + [oref'] -> return oref' _non_singleton -> throwAppError . someBackendError $ "expected exactly one reference" gyLogInfo' "" $ printf "Locked ORef %s" oref guessRefInputRun refInputORef oref myGuess -tryRefInputConsume :: GYTxGameMonad m => Wallets -> m () -tryRefInputConsume Wallets{..} = do +tryRefInputConsume :: (GYTxGameMonad m) => Wallets -> m () +tryRefInputConsume Wallets {..} = do -- Approach: Create a new output with 60% of total ada. Mark this UTxO as reference input and try sending this same 60%, or any amount greater than 40% of this original balance. Since coin balancer can't consume this UTxO, it won't be able to build for it. asUser w1 $ do walletBalance <- queryBalance $ userAddr w1 let walletLovelaceBalance = fst $ valueSplitAda walletBalance - lovelaceToSend = (walletLovelaceBalance `div` 10) * 6 -- send 60% of total ada + lovelaceToSend = (walletLovelaceBalance `div` 10) * 6 -- send 60% of total ada lovelaceToSendValue = valueFromLovelace lovelaceToSend txBody <- buildTxBody . mustHaveOutput $ mkGYTxOutNoDatum (userAddr w1) lovelaceToSendValue signAndSubmitConfirmed_ txBody let bodyUtxos = utxosToList $ txBodyUTxOs txBody - desiredOutputRef <- case utxoRef <$> find (\GYUTxO{ utxoValue } -> utxoValue == lovelaceToSendValue) bodyUtxos of - Nothing -> throwAppError . someBackendError $ "Shouldn't happen: Couldn't find the desired UTxO" - Just ref -> pure ref - buildTxBody (mustHaveRefInput @'PlutusV2 desiredOutputRef <> mustHaveOutput (mkGYTxOutNoDatum (userAddr w1) lovelaceToSendValue)) + desiredOutputRef <- case utxoRef <$> find (\GYUTxO {utxoValue} -> utxoValue == lovelaceToSendValue) bodyUtxos of + Nothing -> throwAppError . someBackendError $ "Shouldn't happen: Couldn't find the desired UTxO" + Just ref -> pure ref + buildTxBody (mustHaveRefInput @'PlutusV2 desiredOutputRef <> mustHaveOutput (mkGYTxOutNoDatum (userAddr w1) lovelaceToSendValue)) >>= signAndSubmitConfirmed_ diff --git a/tests/GeniusYield/Test/SlotConfig.hs b/tests/GeniusYield/Test/SlotConfig.hs index 184fe8f3..4ad8e652 100644 --- a/tests/GeniusYield/Test/SlotConfig.hs +++ b/tests/GeniusYield/Test/SlotConfig.hs @@ -1,23 +1,23 @@ -module GeniusYield.Test.SlotConfig - ( slotConversionTests - ) where +module GeniusYield.Test.SlotConfig ( + slotConversionTests, +) where -import Data.Time.Clock (UTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) -import Test.QuickCheck -import Test.QuickCheck.Instances.Time () -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Instances.Time () +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck -import qualified Cardano.Api as Api -import qualified Ouroboros.Consensus.BlockchainTime as Ouroboros -import qualified Ouroboros.Consensus.HardFork.History as Ouroboros +import Cardano.Api qualified as Api +import Ouroboros.Consensus.BlockchainTime qualified as Ouroboros +import Ouroboros.Consensus.HardFork.History qualified as Ouroboros -import GeniusYield.CardanoApi.EraHistory (extractEraSummaries) -import GeniusYield.Imports -import GeniusYield.Providers.Common (preprodEraHist, previewEraHist) -import GeniusYield.Types +import GeniusYield.CardanoApi.EraHistory (extractEraSummaries) +import GeniusYield.Imports +import GeniusYield.Providers.Common (preprodEraHist, previewEraHist) +import GeniusYield.Types slotToTime :: forall xs. Ouroboros.SystemStart -> Ouroboros.Interpreter xs -> Api.SlotNo -> Either String UTCTime slotToTime systemStart eraHistory x = bimap show (Ouroboros.fromRelativeTime systemStart) res @@ -27,12 +27,14 @@ slotToTime systemStart eraHistory x = bimap show (Ouroboros.fromRelativeTime sys timeToSlot :: forall xs. Ouroboros.SystemStart -> Ouroboros.Interpreter xs -> UTCTime -> Either String Api.SlotNo timeToSlot systemStart eraHistory utc = first show res where - res = Ouroboros.interpretQuery eraHistory $ (\(slot,_,_) -> slot) + res = + Ouroboros.interpretQuery eraHistory $ + (\(slot, _, _) -> slot) <$> Ouroboros.wallclockToSlot (Ouroboros.toRelativeTime systemStart utc) checkTimeToSlot :: Api.EraHistory -> Property -checkTimeToSlot eraHistory - = forAll (Ouroboros.SystemStart <$> arbitrary) $ \systemStart -> +checkTimeToSlot eraHistory = + forAll (Ouroboros.SystemStart <$> arbitrary) $ \systemStart -> forAll (arbitraryTimeInRange systemStart eraEnd) $ \utc -> either error id $ do let Api.EraHistory interpreter = eraHistory expected <- timeToSlot systemStart interpreter utc @@ -47,36 +49,40 @@ checkTimeToSlot eraHistory (_, eraEnd) = Ouroboros.summaryBounds summaries checkSlotToTime :: Api.EraHistory -> Property -checkSlotToTime eraHistory - = forAll (Ouroboros.SystemStart <$> arbitrary) $ \systemStart -> +checkSlotToTime eraHistory = + forAll (Ouroboros.SystemStart <$> arbitrary) $ \systemStart -> -- Also see: [Slot Config Design] forAll (arbitrarySlotBefore eraEnd) $ \slot -> either error id $ do - let gslot = slotFromApi slot - Api.EraHistory interpreter = eraHistory - expectedRes <- slotToTime systemStart interpreter slot + let gslot = slotFromApi slot + Api.EraHistory interpreter = eraHistory + expectedRes <- slotToTime systemStart interpreter slot - slotCfg <- makeSlotConfig systemStart eraHistory - let actualRes = posixSecondsToUTCTime (timeToPOSIX $ slotToBeginTimePure slotCfg gslot) - pure $ expectedRes === actualRes + slotCfg <- makeSlotConfig systemStart eraHistory + let actualRes = posixSecondsToUTCTime (timeToPOSIX $ slotToBeginTimePure slotCfg gslot) + pure $ expectedRes === actualRes where summaries = extractEraSummaries eraHistory (_, eraEnd) = Ouroboros.summaryBounds summaries slotConversionTests :: TestTree -slotConversionTests = testGroup "SlotToFromTime" - [ testGroup "preprod" - [ testProperty "SlotToTime" - $ checkSlotToTime (Api.EraHistory preprodEraHist) - , testProperty "TimeToSlot" - $ checkTimeToSlot (Api.EraHistory preprodEraHist) - ] - , testGroup "preview" - [ testProperty "SlotToTime" - $ checkSlotToTime (Api.EraHistory previewEraHist) - , testProperty "TimeToSlot" - $ checkTimeToSlot (Api.EraHistory previewEraHist) - ] - ] +slotConversionTests = + testGroup + "SlotToFromTime" + [ testGroup + "preprod" + [ testProperty "SlotToTime" $ + checkSlotToTime (Api.EraHistory preprodEraHist) + , testProperty "TimeToSlot" $ + checkTimeToSlot (Api.EraHistory preprodEraHist) + ] + , testGroup + "preview" + [ testProperty "SlotToTime" $ + checkSlotToTime (Api.EraHistory previewEraHist) + , testProperty "TimeToSlot" $ + checkTimeToSlot (Api.EraHistory previewEraHist) + ] + ] -- | Greater than or equal to system start, less than or equal to final era bound. arbitraryTimeInRange :: Ouroboros.SystemStart -> Ouroboros.EraEnd -> Gen UTCTime @@ -84,11 +90,12 @@ arbitraryTimeInRange sysStart eraEnd = arbitrary `suchThat` (\x -> x >= absStart where absStart = Ouroboros.getSystemStart sysStart ltEnd x = case eraEnd of - Ouroboros.EraEnd bo -> x < Ouroboros.fromRelativeTime sysStart (Ouroboros.boundTime bo) + Ouroboros.EraEnd bo -> x < Ouroboros.fromRelativeTime sysStart (Ouroboros.boundTime bo) Ouroboros.EraUnbounded -> True -- | Generate an arbitrary slot before given era end. arbitrarySlotBefore :: Ouroboros.EraEnd -> Gen Api.SlotNo -arbitrarySlotBefore eraEnd = (Api.SlotNo <$> arbitrary) `suchThat` \slotNo -> case eraEnd of - Ouroboros.EraEnd bo -> slotNo < Ouroboros.boundSlot bo +arbitrarySlotBefore eraEnd = + (Api.SlotNo <$> arbitrary) `suchThat` \slotNo -> case eraEnd of + Ouroboros.EraEnd bo -> slotNo < Ouroboros.boundSlot bo Ouroboros.EraUnbounded -> True diff --git a/tests/GeniusYield/Test/Stake.hs b/tests/GeniusYield/Test/Stake.hs index c63aeab1..1ef2c010 100644 --- a/tests/GeniusYield/Test/Stake.hs +++ b/tests/GeniusYield/Test/Stake.hs @@ -1,18 +1,19 @@ -module GeniusYield.Test.Stake - ( stakeTests - ) where +module GeniusYield.Test.Stake ( + stakeTests, +) where -import Data.Foldable (for_) -import GeniusYield.GYConfig -import GeniusYield.Transaction (GYCoinSelectionStrategy) -import GeniusYield.TxBuilder -import GeniusYield.Types -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertBool, assertFailure, testCase) +import Data.Foldable (for_) +import GeniusYield.GYConfig +import GeniusYield.Transaction (GYCoinSelectionStrategy) +import GeniusYield.TxBuilder +import GeniusYield.Types +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase) stakeTests :: GYCoreConfig -> TestTree stakeTests config = - testGroup "stake" + testGroup + "stake" [ testCase "able to build balanced transaction involving withdrawal" $ do withCfgProviders config mempty $ \provider@GYProviders {..} -> do -- This stake credential and it's corresponding address was found from net, and in case is not valid anymore, it's easy to replace it with a valid one. This test was written as there was some trouble faced in accumulation of rewards in our private testnet. diff --git a/tests/atlas-tests.hs b/tests/atlas-tests.hs index ea3c24bf..5d90966b 100644 --- a/tests/atlas-tests.hs +++ b/tests/atlas-tests.hs @@ -1,28 +1,34 @@ module Main (main) where -import qualified Cardano.Api as Api -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import System.Directory (doesFileExist) -import System.FilePath (()) -import Test.Tasty (defaultMain, testGroup) -import Test.Tasty.Golden (goldenVsString) -import Test.Tasty.HUnit (assertEqual, testCase, (@=?), - (@?=)) - -import GeniusYield.Examples.Gift -import GeniusYield.GYConfig (coreConfigIO, - findMaestroTokenAndNetId) -import GeniusYield.Imports -import GeniusYield.Test.CoinSelection (coinSelectionTests) -import GeniusYield.Test.Config (configTests) -import GeniusYield.Test.GYTxBody (gyTxBodyTests) -import GeniusYield.Test.GYTxSkeleton (gyTxSkeletonTests) -import GeniusYield.Test.Providers (providersTests) -import GeniusYield.Test.RefInput (refInputTests) -import GeniusYield.Test.SlotConfig (slotConversionTests) -import GeniusYield.Test.Stake (stakeTests) -import GeniusYield.Types +import Cardano.Api qualified as Api +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import System.Directory (doesFileExist) +import System.FilePath (()) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.Golden (goldenVsString) +import Test.Tasty.HUnit ( + assertEqual, + testCase, + (@=?), + (@?=), + ) + +import GeniusYield.Examples.Gift +import GeniusYield.GYConfig ( + coreConfigIO, + findMaestroTokenAndNetId, + ) +import GeniusYield.Imports +import GeniusYield.Test.CoinSelection (coinSelectionTests) +import GeniusYield.Test.Config (configTests) +import GeniusYield.Test.GYTxBody (gyTxBodyTests) +import GeniusYield.Test.GYTxSkeleton (gyTxSkeletonTests) +import GeniusYield.Test.Providers (providersTests) +import GeniusYield.Test.RefInput (refInputTests) +import GeniusYield.Test.SlotConfig (slotConversionTests) +import GeniusYield.Test.Stake (stakeTests) +import GeniusYield.Types ------------------------------------------------------------------------------- -- main @@ -30,53 +36,53 @@ import GeniusYield.Types main :: IO () main = do - configs <- forM ["maestro-config.json", "blockfrost-config.json"] coreConfigIO - (providerToken, netId) <- findMaestroTokenAndNetId configs - rootDir <- findPackageRoot - defaultMain $ testGroup "atlas" - [ testGroup "serializeToRawBytes" - [ goldenVsString "serialized-v1" (rootDir "fixtures" "script-v1.cbor") $ do - return $ LBS.fromStrict $ Api.serialiseToRawBytes simpleScriptAPIv1 - , goldenVsString "serialized-v2" (rootDir "fixtures" "script-v2.cbor") $ do - return $ LBS.fromStrict $ Api.serialiseToRawBytes simpleScriptAPIv2 - - , testCase "Encoding is the same" $ do - v1 <- BS.readFile $ rootDir "fixtures" "script-v1.cbor" - v2 <- BS.readFile $ rootDir "fixtures" "script-v2.cbor" - assertEqual "v1==v2" v1 v2 - ] - - , testGroup "textEnvelope" - [ goldenVsString "serialized-v1" (rootDir "fixtures" "script-env-v1.json") $ do - return $ Api.textEnvelopeToJSON Nothing simpleScriptAPIv1 - , goldenVsString "serialized-v2" (rootDir "fixtures" "script-env-v2.json") $ do - return $ Api.textEnvelopeToJSON Nothing simpleScriptAPIv2 - - -- we can deserialize v1 as v1. - , testCase "deserialize v1" $ do - e <- Api.readFileTextEnvelope (Api.proxyToAsType Proxy) (Api.File $ rootDir "fixtures" "script-env-v1.json") - Right simpleScriptAPIv1 @=? first show e - - , testCase "deserialize v1" $ do - e <- Api.readFileTextEnvelope (Api.proxyToAsType Proxy) (Api.File $ rootDir "fixtures" "script-env-v1.json") - - let expected :: Either String (Api.PlutusScript Api.PlutusScriptV2) - expected = Left "(TextEnvelopeTypeError [TextEnvelopeType \"PlutusScriptV2\"] (TextEnvelopeType \"PlutusScriptV1\"))" - - expected @=? first (dropWhile (/= '(') . show) e - ] - , testCase "able to read simple-script" $ do - ss <- readSimpleScript (mockDataDir "simple-script.json") - ss @?= RequireAllOf [RequireTimeAfter (slotFromWord64 1000), RequireSignature "966e394a544f242081e41d1965137b1bb412ac230d40ed5407821c37", RequireMOf 2 [RequireSignature "2f3d4cf10d0471a1db9f2d2907de867968c27bca6272f062cd1c2413", RequireSignature "f856c0c5839bab22673747d53f1ae9eed84afafb085f086e8e988614",RequireSignature "b275b08c999097247f7c17e77007c7010cd19f20cc086ad99d398538"], RequireAnyOf [RequireSignature "4d780ed1bfc88cbd4da3f48de91fe728c3530d662564bf5a284b5321", RequireSignature "3a94d6d4e786a3f5d439939cafc0536f6abc324fb8404084d6034bf8"]] - , slotConversionTests - , coinSelectionTests - , gyTxBodyTests - , configTests - , gyTxSkeletonTests - , refInputTests - , stakeTests (head configs) - , providersTests configs providerToken netId - ] + configs <- forM ["maestro-config.json", "blockfrost-config.json"] coreConfigIO + (providerToken, netId) <- findMaestroTokenAndNetId configs + rootDir <- findPackageRoot + defaultMain $ + testGroup + "atlas" + [ testGroup + "serializeToRawBytes" + [ goldenVsString "serialized-v1" (rootDir "fixtures" "script-v1.cbor") $ do + return $ LBS.fromStrict $ Api.serialiseToRawBytes simpleScriptAPIv1 + , goldenVsString "serialized-v2" (rootDir "fixtures" "script-v2.cbor") $ do + return $ LBS.fromStrict $ Api.serialiseToRawBytes simpleScriptAPIv2 + , testCase "Encoding is the same" $ do + v1 <- BS.readFile $ rootDir "fixtures" "script-v1.cbor" + v2 <- BS.readFile $ rootDir "fixtures" "script-v2.cbor" + assertEqual "v1==v2" v1 v2 + ] + , testGroup + "textEnvelope" + [ goldenVsString "serialized-v1" (rootDir "fixtures" "script-env-v1.json") $ do + return $ Api.textEnvelopeToJSON Nothing simpleScriptAPIv1 + , goldenVsString "serialized-v2" (rootDir "fixtures" "script-env-v2.json") $ do + return $ Api.textEnvelopeToJSON Nothing simpleScriptAPIv2 + , -- we can deserialize v1 as v1. + testCase "deserialize v1" $ do + e <- Api.readFileTextEnvelope (Api.proxyToAsType Proxy) (Api.File $ rootDir "fixtures" "script-env-v1.json") + Right simpleScriptAPIv1 @=? first show e + , testCase "deserialize v1" $ do + e <- Api.readFileTextEnvelope (Api.proxyToAsType Proxy) (Api.File $ rootDir "fixtures" "script-env-v1.json") + + let expected :: Either String (Api.PlutusScript Api.PlutusScriptV2) + expected = Left "(TextEnvelopeTypeError [TextEnvelopeType \"PlutusScriptV2\"] (TextEnvelopeType \"PlutusScriptV1\"))" + + expected @=? first (dropWhile (/= '(') . show) e + ] + , testCase "able to read simple-script" $ do + ss <- readSimpleScript (mockDataDir "simple-script.json") + ss @?= RequireAllOf [RequireTimeAfter (slotFromWord64 1000), RequireSignature "966e394a544f242081e41d1965137b1bb412ac230d40ed5407821c37", RequireMOf 2 [RequireSignature "2f3d4cf10d0471a1db9f2d2907de867968c27bca6272f062cd1c2413", RequireSignature "f856c0c5839bab22673747d53f1ae9eed84afafb085f086e8e988614", RequireSignature "b275b08c999097247f7c17e77007c7010cd19f20cc086ad99d398538"], RequireAnyOf [RequireSignature "4d780ed1bfc88cbd4da3f48de91fe728c3530d662564bf5a284b5321", RequireSignature "3a94d6d4e786a3f5d439939cafc0536f6abc324fb8404084d6034bf8"]] + , slotConversionTests + , coinSelectionTests + , gyTxBodyTests + , configTests + , gyTxSkeletonTests + , refInputTests + , stakeTests (head configs) + , providersTests configs providerToken netId + ] ------------------------------------------------------------------------------- -- simple script @@ -92,12 +98,13 @@ simpleScriptAPIv2 = validatorToApi giftValidatorV2 -- utilities ------------------------------------------------------------------------------- --- | Useful when tests are run with @cabal run@ from the root of the project, --- not the package. +{- | Useful when tests are run with @cabal run@ from the root of the project, +not the package. +-} findPackageRoot :: IO FilePath findPackageRoot = do - here <- doesFileExist "atlas-cardano.cabal" - if here + here <- doesFileExist "atlas-cardano.cabal" + if here then return "." else fail "Cannot find package root" From e52a873ed3b4c2d3b9cdb2aaff8c7e8985eec85a Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Thu, 5 Sep 2024 21:06:38 +0530 Subject: [PATCH 4/9] feat(#348): update formatter config --- fourmolu.yaml | 4 +- .../GeniusYield/OnChain/AStakeValidator.hs | 14 +- .../OnChain/Examples/ReadOracle.hs | 20 +- src-plutustx/GeniusYield/OnChain/TestToken.hs | 16 +- src/GeniusYield/Api/TestTokens.hs | 2 +- src/GeniusYield/CardanoApi/Query.hs | 4 +- src/GeniusYield/Examples/Gift.hs | 10 +- src/GeniusYield/Examples/Limbo.hs | 10 +- src/GeniusYield/Examples/Treat.hs | 10 +- src/GeniusYield/GYConfig.hs | 130 ++--- src/GeniusYield/HTTP/Errors.hs | 2 +- src/GeniusYield/Imports.hs | 10 +- src/GeniusYield/Providers/Blockfrost.hs | 222 ++++---- src/GeniusYield/Providers/Common.hs | 240 ++++----- src/GeniusYield/Providers/GCP.hs | 24 +- src/GeniusYield/Providers/Kupo.hs | 60 +-- src/GeniusYield/Providers/LiteChainIndex.hs | 106 ++-- src/GeniusYield/Providers/Maestro.hs | 230 ++++---- src/GeniusYield/Providers/Node.hs | 4 +- src/GeniusYield/Providers/Node/AwaitTx.hs | 42 +- src/GeniusYield/Providers/Node/Query.hs | 8 +- src/GeniusYield/Providers/Sentry.hs | 78 +-- src/GeniusYield/ReadJSON.hs | 2 +- src/GeniusYield/Swagger/Utils.hs | 2 +- src/GeniusYield/Test/Clb.hs | 310 +++++------ src/GeniusYield/Test/FeeTracker.hs | 68 +-- src/GeniusYield/Test/Privnet/Asserts.hs | 8 +- src/GeniusYield/Test/Privnet/Examples/Gift.hs | 10 +- src/GeniusYield/Test/Privnet/Setup.hs | 24 +- src/GeniusYield/Test/Privnet/Utils.hs | 2 +- src/GeniusYield/Test/Utils.hs | 84 +-- src/GeniusYield/Transaction.hs | 492 +++++++++--------- src/GeniusYield/Transaction/CBOR.hs | 64 +-- src/GeniusYield/Transaction/CoinSelection.hs | 288 +++++----- src/GeniusYield/Transaction/Common.hs | 24 +- src/GeniusYield/TxBuilder.hs | 36 +- src/GeniusYield/TxBuilder/Class.hs | 158 +++--- src/GeniusYield/TxBuilder/Common.hs | 102 ++-- src/GeniusYield/TxBuilder/Errors.hs | 6 +- src/GeniusYield/TxBuilder/IO/Builder.hs | 40 +- src/GeniusYield/TxBuilder/Query/Class.hs | 44 +- src/GeniusYield/Types/Ada.hs | 2 +- src/GeniusYield/Types/Address.hs | 62 +-- src/GeniusYield/Types/Certificate.hs | 18 +- src/GeniusYield/Types/Datum.hs | 4 +- src/GeniusYield/Types/Key.hs | 30 +- src/GeniusYield/Types/Ledger.hs | 2 +- src/GeniusYield/Types/Logging.hs | 50 +- src/GeniusYield/Types/OpenApi.hs | 42 +- src/GeniusYield/Types/PaymentKeyHash.hs | 10 +- src/GeniusYield/Types/Providers.hs | 96 ++-- src/GeniusYield/Types/PubKeyHash.hs | 12 +- src/GeniusYield/Types/Redeemer.hs | 4 +- src/GeniusYield/Types/Script.hs | 112 ++-- src/GeniusYield/Types/Script/SimpleScript.hs | 4 +- src/GeniusYield/Types/Slot.hs | 6 +- src/GeniusYield/Types/SlotConfig.hs | 242 ++++----- src/GeniusYield/Types/StakeKeyHash.hs | 2 +- src/GeniusYield/Types/Time.hs | 2 +- src/GeniusYield/Types/Tx.hs | 6 +- src/GeniusYield/Types/TxBody.hs | 32 +- src/GeniusYield/Types/TxCert/Internal.hs | 18 +- src/GeniusYield/Types/TxIn.hs | 40 +- src/GeniusYield/Types/TxMetadata.hs | 6 +- src/GeniusYield/Types/TxOut.hs | 32 +- src/GeniusYield/Types/TxOutRef.hs | 38 +- src/GeniusYield/Types/TxWdrl.hs | 18 +- src/GeniusYield/Types/UTxO.hs | 108 ++-- src/GeniusYield/Types/Value.hs | 88 ++-- src/GeniusYield/Types/Wallet.hs | 50 +- src/GeniusYield/Utils.hs | 4 +- .../Test/Unified/BetRef/PlaceBet.hs | 120 ++--- .../Test/Unified/BetRef/TakePot.hs | 112 ++-- .../Test/Unified/OnChain/BetRef.hs | 40 +- tests/GeniusYield/Test/CoinSelection.hs | 158 +++--- tests/GeniusYield/Test/GYTxBody.hs | 36 +- tests/GeniusYield/Test/GYTxSkeleton.hs | 8 +- .../Test/OnChain/GuessRefInputDatum.hs | 56 +- tests/GeniusYield/Test/Providers.hs | 136 ++--- tests/GeniusYield/Test/Providers/Mashup.hs | 6 +- tests/GeniusYield/Test/RefInput.hs | 6 +- tests/GeniusYield/Test/SlotConfig.hs | 36 +- 82 files changed, 2433 insertions(+), 2431 deletions(-) diff --git a/fourmolu.yaml b/fourmolu.yaml index c7f07713..2bd0fdce 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1,7 +1,9 @@ indentation: 2 comma-style: leading record-brace-space: true -indent-wheres: true +indent-wheres: false respectful: true haddock-style: multi-line newlines-between-decls: 1 +single-constraint-parens: never +single-deriving-parens: never diff --git a/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs b/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs index 20a196a4..ba934b33 100644 --- a/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs +++ b/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs @@ -20,12 +20,12 @@ mkAStakeValidator addr _ ctx' = case scriptContextPurpose ctx of Certifying _ -> () Rewarding _ -> if paidToAddress then () else error () _ -> error () - where - ctx :: ScriptContext - ctx = unsafeFromBuiltinData ctx' + where + ctx :: ScriptContext + ctx = unsafeFromBuiltinData ctx' - info :: TxInfo - info = scriptContextTxInfo ctx + info :: TxInfo + info = scriptContextTxInfo ctx - paidToAddress :: Bool - paidToAddress = any (\o -> txOutAddress o == addr) $ txInfoOutputs info + paidToAddress :: Bool + paidToAddress = any (\o -> txOutAddress o == addr) $ txInfoOutputs info diff --git a/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs b/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs index db0817fd..e29edb35 100644 --- a/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs +++ b/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs @@ -21,16 +21,16 @@ mkReadOracleValidator :: BuiltinData -> BuiltinData -> BuiltinData -> () mkReadOracleValidator _ _ ctx' | any (hasOutputDatum . txOutDatum) refins = () | otherwise = error () - where - ctx :: ScriptContext - ctx = unsafeFromBuiltinData ctx' + where + ctx :: ScriptContext + ctx = unsafeFromBuiltinData ctx' - info :: TxInfo - info = scriptContextTxInfo ctx + info :: TxInfo + info = scriptContextTxInfo ctx - refins :: [TxOut] - refins = map txInInfoResolved (txInfoReferenceInputs info) + refins :: [TxOut] + refins = map txInInfoResolved (txInfoReferenceInputs info) - hasOutputDatum :: OutputDatum -> Bool - hasOutputDatum (OutputDatum _) = True - hasOutputDatum _ = False + hasOutputDatum :: OutputDatum -> Bool + hasOutputDatum (OutputDatum _) = True + hasOutputDatum _ = False diff --git a/src-plutustx/GeniusYield/OnChain/TestToken.hs b/src-plutustx/GeniusYield/OnChain/TestToken.hs index 546e7f15..9eb450a2 100644 --- a/src-plutustx/GeniusYield/OnChain/TestToken.hs +++ b/src-plutustx/GeniusYield/OnChain/TestToken.hs @@ -25,14 +25,14 @@ mkTestTokenPolicy amt tn utxo _ ctx' | tn /= tn' = traceError "wrong token" | amt /= amt' = traceError "wrong amount" | otherwise = () - where - ctx :: ScriptContext - ctx = unsafeFromBuiltinData ctx' + where + ctx :: ScriptContext + ctx = unsafeFromBuiltinData ctx' - info :: TxInfo - info = scriptContextTxInfo ctx + info :: TxInfo + info = scriptContextTxInfo ctx - [(_, tn', amt')] = flattenValue $ txInfoMint info + [(_, tn', amt')] = flattenValue $ txInfoMint info - hasn'tUTxO :: Bool - hasn'tUTxO = all (\i -> txInInfoOutRef i /= utxo) $ txInfoInputs info + hasn'tUTxO :: Bool + hasn'tUTxO = all (\i -> txInInfoOutRef i /= utxo) $ txInfoInputs info diff --git a/src/GeniusYield/Api/TestTokens.hs b/src/GeniusYield/Api/TestTokens.hs index 45397c20..95cb8930 100644 --- a/src/GeniusYield/Api/TestTokens.hs +++ b/src/GeniusYield/Api/TestTokens.hs @@ -17,7 +17,7 @@ import GeniusYield.TxBuilder import GeniusYield.Types mintTestTokens :: - (GYTxUserQueryMonad m) => + GYTxUserQueryMonad m => GYTokenName -> Natural -> m (GYAssetClass, GYTxSkeleton 'PlutusV2) diff --git a/src/GeniusYield/CardanoApi/Query.hs b/src/GeniusYield/CardanoApi/Query.hs index cd12273b..27ce5ca6 100644 --- a/src/GeniusYield/CardanoApi/Query.hs +++ b/src/GeniusYield/CardanoApi/Query.hs @@ -31,8 +31,8 @@ import GeniusYield.Types ------------------------------------------------------------------------------- newtype CardanoQueryException = CardanoQueryException String - deriving stock (Show) - deriving anyclass (Exception) + deriving stock Show + deriving anyclass Exception ------------------------------------------------------------------------------- -- Low-level query runners diff --git a/src/GeniusYield/Examples/Gift.hs b/src/GeniusYield/Examples/Gift.hs index 77e70ec6..958ad285 100644 --- a/src/GeniusYield/Examples/Gift.hs +++ b/src/GeniusYield/Examples/Gift.hs @@ -30,12 +30,12 @@ giftScript = UPLC.LamAbs ann redeemerName $ UPLC.LamAbs ann scName $ UPLC.Var ann scName - where - ann = () + where + ann = () - datumName = UPLC.Name "datum" (UPLC.Unique 0) - redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) - scName = UPLC.Name "sc" (UPLC.Unique 2) + datumName = UPLC.Name "datum" (UPLC.Unique 0) + redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) + scName = UPLC.Name "sc" (UPLC.Unique 2) giftScript' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () giftScript' = toDeBruijn giftScript diff --git a/src/GeniusYield/Examples/Limbo.hs b/src/GeniusYield/Examples/Limbo.hs index 70c34d48..4c74da63 100644 --- a/src/GeniusYield/Examples/Limbo.hs +++ b/src/GeniusYield/Examples/Limbo.hs @@ -29,12 +29,12 @@ limboScript = UPLC.LamAbs ann redeemerName $ UPLC.LamAbs ann scName $ UPLC.Error ann - where - ann = () + where + ann = () - datumName = UPLC.Name "datum" (UPLC.Unique 0) - redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) - scName = UPLC.Name "sc" (UPLC.Unique 2) + datumName = UPLC.Name "datum" (UPLC.Unique 0) + redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) + scName = UPLC.Name "sc" (UPLC.Unique 2) limboScript' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () limboScript' = toDeBruijn limboScript diff --git a/src/GeniusYield/Examples/Treat.hs b/src/GeniusYield/Examples/Treat.hs index 50baaae1..d63a2788 100644 --- a/src/GeniusYield/Examples/Treat.hs +++ b/src/GeniusYield/Examples/Treat.hs @@ -37,12 +37,12 @@ treatScript = ann (UPLC.Builtin ann PLC.SerialiseData) (UPLC.Var ann scName) - where - ann = () + where + ann = () - datumName = UPLC.Name "datum" (UPLC.Unique 0) - redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) - scName = UPLC.Name "sc" (UPLC.Unique 2) + datumName = UPLC.Name "datum" (UPLC.Unique 0) + redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) + scName = UPLC.Name "sc" (UPLC.Unique 2) treatScript' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () treatScript' = toDeBruijn treatScript diff --git a/src/GeniusYield/GYConfig.hs b/src/GeniusYield/GYConfig.hs index 5810e92c..5a41c147 100644 --- a/src/GeniusYield/GYConfig.hs +++ b/src/GeniusYield/GYConfig.hs @@ -76,7 +76,7 @@ data GYCoreProviderInfo = GYNodeKupo {cpiSocketPath :: !FilePath, cpiKupoUrl :: !Text} | GYMaestro {cpiMaestroToken :: !(Confidential Text), cpiTurboSubmit :: !(Maybe Bool)} | GYBlockfrost {cpiBlockfrostKey :: !(Confidential Text)} - deriving stock (Show) + deriving stock Show $( deriveFromJSON defaultOptions @@ -130,7 +130,7 @@ data GYCoreConfig = GYCoreConfig } -- , cfgUtxoCacheEnable :: !Bool - deriving stock (Show) + deriving stock Show $( deriveFromJSON defaultOptions @@ -254,69 +254,69 @@ logTiming providers@GYProviders {..} = , gyGetStakeAddressInfo = gyGetStakeAddressInfo' , gyLog' = gyLog' } - where - wrap :: String -> IO a -> IO a - wrap msg m = do - (!a, !t) <- duration m - gyLog providers "" GYDebug $ msg <> " took " <> show t - pure a - - gyLookupDatum' :: GYLookupDatum - gyLookupDatum' = wrap "gyLookupDatum" . gyLookupDatum - - gySubmitTx' :: GYSubmitTx - gySubmitTx' = wrap "gySubmitTx" . gySubmitTx - - gyAwaitTxConfirmed' :: GYAwaitTx - gyAwaitTxConfirmed' p = wrap "gyAwaitTxConfirmed" . gyAwaitTxConfirmed p - - gySlotActions' :: GYSlotActions - gySlotActions' = - GYSlotActions - { gyGetSlotOfCurrentBlock' = wrap "gyGetSlotOfCurrentBlock" $ gyGetSlotOfCurrentBlock providers - , gyWaitForNextBlock' = wrap "gyWaitForNextBlock" $ gyWaitForNextBlock providers - , gyWaitUntilSlot' = wrap "gyWaitUntilSlot" . gyWaitUntilSlot providers - } - - gyGetParameters' :: GYGetParameters - gyGetParameters' = - GYGetParameters - { gyGetProtocolParameters' = wrap "gyGetProtocolParameters" $ gyGetProtocolParameters providers - , gyGetSystemStart' = wrap "gyGetSystemStart" $ gyGetSystemStart providers - , gyGetEraHistory' = wrap "gyGetEraHistory" $ gyGetEraHistory providers - , gyGetStakePools' = wrap "gyGetStakePools" $ gyGetStakePools providers - , gyGetSlotConfig' = wrap "gyGetSlotConfig" $ gyGetSlotConfig providers - } - - gyQueryUTxO' :: GYQueryUTxO - gyQueryUTxO' = - GYQueryUTxO - { gyQueryUtxosAtTxOutRefs' = wrap "gyQueryUtxosAtTxOutRefs" . gyQueryUtxosAtTxOutRefs providers - , gyQueryUtxosAtTxOutRefsWithDatums' = case gyQueryUtxosAtTxOutRefsWithDatums' gyQueryUTxO of - Nothing -> Nothing - Just q -> Just $ wrap "gyQueryUtxosAtTxOutRefsWithDatums" . q - , gyQueryUtxoAtTxOutRef' = wrap "gyQueryUtxoAtTxOutRef" . gyQueryUtxoAtTxOutRef providers - , gyQueryUtxoRefsAtAddress' = wrap "gyQueryUtxoRefsAtAddress" . gyQueryUtxoRefsAtAddress providers - , gyQueryUtxosAtAddress' = \addr mac -> wrap "gyQueryUtxosAtAddress'" $ gyQueryUtxosAtAddress providers addr mac - , gyQueryUtxosAtAddressWithDatums' = case gyQueryUtxosAtAddressWithDatums' gyQueryUTxO of - Nothing -> Nothing - Just q -> Just $ \addr mac -> wrap "gyQueryUtxosAtAddressWithDatums'" $ q addr mac - , gyQueryUtxosAtAddresses' = wrap "gyQueryUtxosAtAddresses" . gyQueryUtxosAtAddresses providers - , gyQueryUtxosAtAddressesWithDatums' = case gyQueryUtxosAtAddressesWithDatums' gyQueryUTxO of - Nothing -> Nothing - Just q -> Just $ wrap "gyQueryUtxosAtAddressesWithDatums" . q - , gyQueryUtxosAtPaymentCredential' = \cred -> wrap "gyQueryUtxosAtPaymentCredential" . gyQueryUtxosAtPaymentCredential providers cred - , gyQueryUtxosAtPaymentCredWithDatums' = case gyQueryUtxosAtPaymentCredWithDatums' gyQueryUTxO of - Nothing -> Nothing - Just q -> Just $ \cred mac -> wrap "gyQueryUtxosAtPaymentCredWithDatums" $ q cred mac - , gyQueryUtxosAtPaymentCredentials' = wrap "gyQueryUtxosAtPaymentCredentials" . gyQueryUtxosAtPaymentCredentials providers - , gyQueryUtxosAtPaymentCredsWithDatums' = case gyQueryUtxosAtPaymentCredsWithDatums' gyQueryUTxO of - Nothing -> Nothing - Just q -> Just $ wrap "gyQueryUtxosAtPaymentCredsWithDatums" . q - } - - gyGetStakeAddressInfo' :: GYStakeAddress -> IO (Maybe GYStakeAddressInfo) - gyGetStakeAddressInfo' = wrap "gyGetStakeAddressInfo" . gyGetStakeAddressInfo + where + wrap :: String -> IO a -> IO a + wrap msg m = do + (!a, !t) <- duration m + gyLog providers "" GYDebug $ msg <> " took " <> show t + pure a + + gyLookupDatum' :: GYLookupDatum + gyLookupDatum' = wrap "gyLookupDatum" . gyLookupDatum + + gySubmitTx' :: GYSubmitTx + gySubmitTx' = wrap "gySubmitTx" . gySubmitTx + + gyAwaitTxConfirmed' :: GYAwaitTx + gyAwaitTxConfirmed' p = wrap "gyAwaitTxConfirmed" . gyAwaitTxConfirmed p + + gySlotActions' :: GYSlotActions + gySlotActions' = + GYSlotActions + { gyGetSlotOfCurrentBlock' = wrap "gyGetSlotOfCurrentBlock" $ gyGetSlotOfCurrentBlock providers + , gyWaitForNextBlock' = wrap "gyWaitForNextBlock" $ gyWaitForNextBlock providers + , gyWaitUntilSlot' = wrap "gyWaitUntilSlot" . gyWaitUntilSlot providers + } + + gyGetParameters' :: GYGetParameters + gyGetParameters' = + GYGetParameters + { gyGetProtocolParameters' = wrap "gyGetProtocolParameters" $ gyGetProtocolParameters providers + , gyGetSystemStart' = wrap "gyGetSystemStart" $ gyGetSystemStart providers + , gyGetEraHistory' = wrap "gyGetEraHistory" $ gyGetEraHistory providers + , gyGetStakePools' = wrap "gyGetStakePools" $ gyGetStakePools providers + , gyGetSlotConfig' = wrap "gyGetSlotConfig" $ gyGetSlotConfig providers + } + + gyQueryUTxO' :: GYQueryUTxO + gyQueryUTxO' = + GYQueryUTxO + { gyQueryUtxosAtTxOutRefs' = wrap "gyQueryUtxosAtTxOutRefs" . gyQueryUtxosAtTxOutRefs providers + , gyQueryUtxosAtTxOutRefsWithDatums' = case gyQueryUtxosAtTxOutRefsWithDatums' gyQueryUTxO of + Nothing -> Nothing + Just q -> Just $ wrap "gyQueryUtxosAtTxOutRefsWithDatums" . q + , gyQueryUtxoAtTxOutRef' = wrap "gyQueryUtxoAtTxOutRef" . gyQueryUtxoAtTxOutRef providers + , gyQueryUtxoRefsAtAddress' = wrap "gyQueryUtxoRefsAtAddress" . gyQueryUtxoRefsAtAddress providers + , gyQueryUtxosAtAddress' = \addr mac -> wrap "gyQueryUtxosAtAddress'" $ gyQueryUtxosAtAddress providers addr mac + , gyQueryUtxosAtAddressWithDatums' = case gyQueryUtxosAtAddressWithDatums' gyQueryUTxO of + Nothing -> Nothing + Just q -> Just $ \addr mac -> wrap "gyQueryUtxosAtAddressWithDatums'" $ q addr mac + , gyQueryUtxosAtAddresses' = wrap "gyQueryUtxosAtAddresses" . gyQueryUtxosAtAddresses providers + , gyQueryUtxosAtAddressesWithDatums' = case gyQueryUtxosAtAddressesWithDatums' gyQueryUTxO of + Nothing -> Nothing + Just q -> Just $ wrap "gyQueryUtxosAtAddressesWithDatums" . q + , gyQueryUtxosAtPaymentCredential' = \cred -> wrap "gyQueryUtxosAtPaymentCredential" . gyQueryUtxosAtPaymentCredential providers cred + , gyQueryUtxosAtPaymentCredWithDatums' = case gyQueryUtxosAtPaymentCredWithDatums' gyQueryUTxO of + Nothing -> Nothing + Just q -> Just $ \cred mac -> wrap "gyQueryUtxosAtPaymentCredWithDatums" $ q cred mac + , gyQueryUtxosAtPaymentCredentials' = wrap "gyQueryUtxosAtPaymentCredentials" . gyQueryUtxosAtPaymentCredentials providers + , gyQueryUtxosAtPaymentCredsWithDatums' = case gyQueryUtxosAtPaymentCredsWithDatums' gyQueryUTxO of + Nothing -> Nothing + Just q -> Just $ wrap "gyQueryUtxosAtPaymentCredsWithDatums" . q + } + + gyGetStakeAddressInfo' :: GYStakeAddress -> IO (Maybe GYStakeAddressInfo) + gyGetStakeAddressInfo' = wrap "gyGetStakeAddressInfo" . gyGetStakeAddressInfo duration :: IO a -> IO (a, NominalDiffTime) duration m = do diff --git a/src/GeniusYield/HTTP/Errors.hs b/src/GeniusYield/HTTP/Errors.hs index 371d991e..b4cef36f 100644 --- a/src/GeniusYield/HTTP/Errors.hs +++ b/src/GeniusYield/HTTP/Errors.hs @@ -28,7 +28,7 @@ import GeniusYield.Imports type IsGYApiError :: Type -> Constraint class IsGYApiError e where toApiError :: e -> GYApiError - default toApiError :: (Exception e) => e -> GYApiError + default toApiError :: Exception e => e -> GYApiError toApiError e = someBackendError . Txt.pack $ displayException e {- | An example error code can be: "INSUFFICIENT_BALANCE" (i.e. diff --git a/src/GeniusYield/Imports.hs b/src/GeniusYield/Imports.hs index 027412b4..ab85ea46 100644 --- a/src/GeniusYield/Imports.hs +++ b/src/GeniusYield/Imports.hs @@ -79,7 +79,7 @@ import Data.Text.Lazy.Encoding qualified as LTE import GHC.TypeLits (ErrorMessage (..), TypeError) -- | Use 'TODO' instead of 'undefined's -pattern TODO :: () => (HasCallStack) => a +pattern TODO :: () => HasCallStack => a pattern TODO <- (todoMatch -> ()) where TODO = error "TODO" @@ -88,15 +88,15 @@ pattern TODO <- (todoMatch -> ()) todoMatch :: a -> () todoMatch _ = () -findFirst :: (Foldable f) => (a -> Maybe b) -> f a -> Maybe b +findFirst :: Foldable f => (a -> Maybe b) -> f a -> Maybe b findFirst f xs = getFirst (foldMap (coerce f) xs) -- poisonous instances -- (the orphan in plutus-ledger-api was removed in Feb 2022) -instance (TypeError ('Text "Forbidden FromJSON ByteString instance")) => FromJSON ByteString where +instance TypeError ('Text "Forbidden FromJSON ByteString instance") => FromJSON ByteString where parseJSON = error "FromJSON @ByteString" -instance (TypeError ('Text "Forbidden ToJSON ByteString instance")) => ToJSON ByteString where +instance TypeError ('Text "Forbidden ToJSON ByteString instance") => ToJSON ByteString where toJSON = error "ToJSON @ByteString" {- | Decode a lazy 'ByteString' containing UTF-8 encoded text. @@ -119,5 +119,5 @@ hush = either (const Nothing) Just __NOTE:__ This is also defined (& exported) in @transformers-0.6.0.0@, so should be removed once we upgrade to it. -} -hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b +hoistMaybe :: Applicative m => Maybe b -> MaybeT m b hoistMaybe = MaybeT . pure diff --git a/src/GeniusYield/Providers/Blockfrost.hs b/src/GeniusYield/Providers/Blockfrost.hs index 6b9fddd8..b44d0e10 100644 --- a/src/GeniusYield/Providers/Blockfrost.hs +++ b/src/GeniusYield/Providers/Blockfrost.hs @@ -62,7 +62,7 @@ data BlockfrostProviderException | BlpvUnsupportedOperation !Text | BlpvIncorrectEraHistoryLength ![Blockfrost.NetworkEraSummary] deriving stock (Eq, Show) - deriving anyclass (Exception) + deriving anyclass Exception throwBlpvApiError :: Text -> Blockfrost.BlockfrostError -> IO a throwBlpvApiError locationInfo = @@ -93,10 +93,10 @@ amountToValue (Blockfrost.AssetAmount sdiscr) = do cs <- Web.parseUrlPiece csPart tkName <- Web.parseUrlPiece tkNamePart pure . valueSingleton (GYToken cs tkName) $ Money.someDiscreteAmount sdiscr - where - csAndTkname = Money.someDiscreteCurrency sdiscr - -- Blockfrost uses no separator between CS and TkName. - (csPart, tkNamePart) = Text.splitAt 56 csAndTkname + where + csAndTkname = Money.someDiscreteCurrency sdiscr + -- Blockfrost uses no separator between CS and TkName. + (csPart, tkNamePart) = Text.splitAt 56 csAndTkname ------------------------------------------------------------------------------- -- Submit @@ -118,9 +118,9 @@ blockfrostSubmitTx proj tx = do . txIdFromHexE . Text.unpack $ Blockfrost.unTxHash txId - where - locationIdent = "SubmitTx" - handleBlockfrostSubmitError = either (throwIO . SubmitTxException . Text.pack . show . silenceHeadersBlockfrostClientError) pure + where + locationIdent = "SubmitTx" + handleBlockfrostSubmitError = either (throwIO . SubmitTxException . Text.pack . show . silenceHeadersBlockfrostClientError) pure ------------------------------------------------------------------------------- -- Await tx confirmation @@ -129,37 +129,37 @@ blockfrostSubmitTx proj tx = do -- | Awaits for the confirmation of a given 'GYTxId' blockfrostAwaitTxConfirmed :: Blockfrost.Project -> GYAwaitTx blockfrostAwaitTxConfirmed proj p@GYAwaitTxParameters {..} txId = blpAwaitTx 0 - where - blpAwaitTx :: Int -> IO () - blpAwaitTx attempt | maxAttempts <= attempt = throwIO $ GYAwaitTxException p - blpAwaitTx attempt = do - eTxInfo <- blockfrostQueryTx proj txId - case eTxInfo of - Left Blockfrost.BlockfrostNotFound -> - threadDelay checkInterval - >> blpAwaitTx (attempt + 1) - Left err -> throwBlpvApiError "AwaitTx" err - Right txInfo -> - blpAwaitBlock attempt $ - Blockfrost._transactionBlock txInfo - - blpAwaitBlock :: Int -> Blockfrost.BlockHash -> IO () - blpAwaitBlock attempt _ | maxAttempts <= attempt = throwIO $ GYAwaitTxException p - blpAwaitBlock attempt blockHash = do - eBlockInfo <- blockfrostQueryBlock proj blockHash - case eBlockInfo of - Left Blockfrost.BlockfrostNotFound -> - threadDelay checkInterval - >> blpAwaitBlock (attempt + 1) blockHash - Left err -> throwBlpvApiError "AwaitBlock" err - Right blockInfo - | attempt + 1 == maxAttempts -> - when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ - throwIO $ - GYAwaitTxException p - Right blockInfo -> - when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ - threadDelay checkInterval >> blpAwaitBlock (attempt + 1) blockHash + where + blpAwaitTx :: Int -> IO () + blpAwaitTx attempt | maxAttempts <= attempt = throwIO $ GYAwaitTxException p + blpAwaitTx attempt = do + eTxInfo <- blockfrostQueryTx proj txId + case eTxInfo of + Left Blockfrost.BlockfrostNotFound -> + threadDelay checkInterval + >> blpAwaitTx (attempt + 1) + Left err -> throwBlpvApiError "AwaitTx" err + Right txInfo -> + blpAwaitBlock attempt $ + Blockfrost._transactionBlock txInfo + + blpAwaitBlock :: Int -> Blockfrost.BlockHash -> IO () + blpAwaitBlock attempt _ | maxAttempts <= attempt = throwIO $ GYAwaitTxException p + blpAwaitBlock attempt blockHash = do + eBlockInfo <- blockfrostQueryBlock proj blockHash + case eBlockInfo of + Left Blockfrost.BlockfrostNotFound -> + threadDelay checkInterval + >> blpAwaitBlock (attempt + 1) blockHash + Left err -> throwBlpvApiError "AwaitBlock" err + Right blockInfo + | attempt + 1 == maxAttempts -> + when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ + throwIO $ + GYAwaitTxException p + Right blockInfo -> + when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ + threadDelay checkInterval >> blpAwaitBlock (attempt + 1) blockHash blockfrostQueryBlock :: Blockfrost.Project -> @@ -247,11 +247,11 @@ blockfrostUtxosAtAddress proj addr mAssetClass = do case traverse transformUtxo addrUtxos' of Left err -> throwIO $ BlpvDeserializeFailure locationIdent err Right x -> pure $ utxosFromList x - where - locationIdent = "AddressUtxos" - -- This particular error is fine in this case, we can just return empty list. - handler (Left Blockfrost.BlockfrostNotFound) = pure [] - handler other = handleBlockfrostError locationIdent other + where + locationIdent = "AddressUtxos" + -- This particular error is fine in this case, we can just return empty list. + handler (Left Blockfrost.BlockfrostNotFound) = pure [] + handler other = handleBlockfrostError locationIdent other blockfrostUtxosAtPaymentCredential :: Blockfrost.Project -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs blockfrostUtxosAtPaymentCredential proj cred mAssetClass = do @@ -269,11 +269,11 @@ blockfrostUtxosAtPaymentCredential proj cred mAssetClass = do case traverse transformUtxo credUtxos' of Left err -> throwIO $ BlpvDeserializeFailure locationIdent err Right x -> pure $ utxosFromList x - where - locationIdent = "PaymentCredentialUtxos" - -- This particular error is fine in this case, we can just return empty list. - handler (Left Blockfrost.BlockfrostNotFound) = pure [] - handler other = handleBlockfrostError locationIdent other + where + locationIdent = "PaymentCredentialUtxos" + -- This particular error is fine in this case, we can just return empty list. + handler (Left Blockfrost.BlockfrostNotFound) = pure [] + handler other = handleBlockfrostError locationIdent other blockfrostUtxosAtTxOutRef :: Blockfrost.Project -> GYTxOutRef -> IO (Maybe GYUTxO) blockfrostUtxosAtTxOutRef proj ref = do @@ -318,11 +318,11 @@ blockfrostUtxosAtTxOutRef proj ref = do , utxoOutDatum = d , utxoRefScript = ms } - where - -- This particular error is fine in this case, we can just return 'Nothing'. - handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing - handler other = handleBlockfrostError locationIdent $ Just <$> other - locationIdent = "TxUtxos(single)" + where + -- This particular error is fine in this case, we can just return 'Nothing'. + handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing + handler other = handleBlockfrostError locationIdent $ Just <$> other + locationIdent = "TxUtxos(single)" blockfrostUtxosAtTxOutRefs :: Blockfrost.Project -> [GYTxOutRef] -> IO GYUTxOs blockfrostUtxosAtTxOutRefs proj refs = do @@ -356,16 +356,16 @@ blockfrostUtxosAtTxOutRefs proj refs = do case Map.traverseWithKey (traverse . transformUtxoOutput) txUtxoMap' of Left err -> throwIO $ BlpvDeserializeFailure locationIndent err Right res -> pure . utxosFromList . concat $ Map.elems res - where - locationIndent = "TxUtxos" + where + locationIndent = "TxUtxos" - f :: - Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)] -> - (Api.S.TxId, [Blockfrost.UtxoOutput]) -> - IO (Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)]) - f m (tid, os) = do - xs <- forM os $ \o -> lookupScriptHashIO proj (Blockfrost._utxoOutputReferenceScriptHash o) >>= \ms -> return (o, ms) - return $ Map.insert tid xs m + f :: + Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)] -> + (Api.S.TxId, [Blockfrost.UtxoOutput]) -> + IO (Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)]) + f m (tid, os) = do + xs <- forM os $ \o -> lookupScriptHashIO proj (Blockfrost._utxoOutputReferenceScriptHash o) >>= \ms -> return (o, ms) + return $ Map.insert tid xs m -- | Helper to transform a 'Blockfrost.UtxoOutput' into a 'GYUTxO'. transformUtxoOutput :: Api.S.TxId -> (Blockfrost.UtxoOutput, Maybe GYAnyScript) -> Either SomeDeserializeError GYUTxO @@ -465,8 +465,8 @@ blockfrostProtocolParams nid proj = do , cppDRepActivity = THKD (Ledger.EpochInterval 0) , cppMinFeeRefScriptCostPerByte = THKD minBound } - where - errPath = "GeniusYield.Providers.Blockfrost.blockfrostProtocolParams: " + where + errPath = "GeniusYield.Providers.Blockfrost.blockfrostProtocolParams: " blockfrostStakePools :: Blockfrost.Project -> IO (Set Api.S.PoolId) blockfrostStakePools proj = do @@ -485,8 +485,8 @@ blockfrostStakePools proj = do -- Deserialization failure shouldn't happen on blockfrost returned pool id. Left err -> throwIO . BlpvDeserializeFailure locationIdent $ DeserializeErrorBech32 err Right has -> pure $ Set.fromList has - where - locationIdent = "ListPools" + where + locationIdent = "ListPools" blockfrostSystemStart :: Blockfrost.Project -> IO CTime.SystemStart blockfrostSystemStart proj = do @@ -497,26 +497,26 @@ blockfrostEraHistory :: Blockfrost.Project -> IO Api.EraHistory blockfrostEraHistory proj = do eraSumms <- Blockfrost.runBlockfrost proj Blockfrost.getNetworkEras >>= handleBlockfrostError "EraHistory" maybe (throwIO $ BlpvIncorrectEraHistoryLength eraSumms) pure $ parseEraHist mkEra eraSumms - where - mkBound Blockfrost.NetworkEraBound {_boundEpoch, _boundSlot, _boundTime} = - Ouroboros.Bound - { boundTime = CTime.RelativeTime _boundTime - , boundSlot = CSlot.SlotNo $ fromIntegral _boundSlot - , boundEpoch = CSlot.EpochNo $ fromIntegral _boundEpoch - } - mkEraParams Blockfrost.NetworkEraParameters {_parametersEpochLength, _parametersSlotLength, _parametersSafeZone} = - Ouroboros.EraParams - { eraEpochSize = CSlot.EpochSize $ fromIntegral _parametersEpochLength - , eraSlotLength = CTime.mkSlotLength _parametersSlotLength - , eraSafeZone = Ouroboros.StandardSafeZone _parametersSafeZone - , eraGenesisWin = fromIntegral _parametersSafeZone -- TODO: Get it from provider? It is supposed to be 3k/f where k is security parameter (at present 2160) and f is active slot coefficient. Usually ledger set the safe zone size such that it guarantees at least k blocks... - } - mkEra Blockfrost.NetworkEraSummary {_networkEraStart, _networkEraEnd, _networkEraParameters} = - Ouroboros.EraSummary - { eraStart = mkBound _networkEraStart - , eraEnd = Ouroboros.EraEnd $ mkBound _networkEraEnd - , eraParams = mkEraParams _networkEraParameters - } + where + mkBound Blockfrost.NetworkEraBound {_boundEpoch, _boundSlot, _boundTime} = + Ouroboros.Bound + { boundTime = CTime.RelativeTime _boundTime + , boundSlot = CSlot.SlotNo $ fromIntegral _boundSlot + , boundEpoch = CSlot.EpochNo $ fromIntegral _boundEpoch + } + mkEraParams Blockfrost.NetworkEraParameters {_parametersEpochLength, _parametersSlotLength, _parametersSafeZone} = + Ouroboros.EraParams + { eraEpochSize = CSlot.EpochSize $ fromIntegral _parametersEpochLength + , eraSlotLength = CTime.mkSlotLength _parametersSlotLength + , eraSafeZone = Ouroboros.StandardSafeZone _parametersSafeZone + , eraGenesisWin = fromIntegral _parametersSafeZone -- TODO: Get it from provider? It is supposed to be 3k/f where k is security parameter (at present 2160) and f is active slot coefficient. Usually ledger set the safe zone size such that it guarantees at least k blocks... + } + mkEra Blockfrost.NetworkEraSummary {_networkEraStart, _networkEraEnd, _networkEraParameters} = + Ouroboros.EraSummary + { eraStart = mkBound _networkEraStart + , eraEnd = Ouroboros.EraEnd $ mkBound _networkEraEnd + , eraParams = mkEraParams _networkEraParameters + } ------------------------------------------------------------------------------- -- Datum lookup @@ -538,11 +538,11 @@ blockfrostLookupDatum p dh = do Right bd -> pure $ datumFromPlutus' bd ) datumMaybe - where - -- This particular error is fine in this case, we can just return 'Nothing'. - handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing - handler other = handleBlockfrostError locationIdent $ Just <$> other - locationIdent = "LookupDatum" + where + -- This particular error is fine in this case, we can just return 'Nothing'. + handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing + handler other = handleBlockfrostError locationIdent $ Just <$> other + locationIdent = "LookupDatum" ------------------------------------------------------------------------------- -- Account info @@ -551,20 +551,20 @@ blockfrostLookupDatum p dh = do blockfrostStakeAddressInfo :: Blockfrost.Project -> GYStakeAddress -> IO (Maybe GYStakeAddressInfo) blockfrostStakeAddressInfo p saddr = do Blockfrost.runBlockfrost p (Blockfrost.getAccount (Blockfrost.mkAddress $ stakeAddressToText saddr)) >>= handler - where - -- This particular error is fine. - handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing - handler other = - handleBlockfrostError "Account" $ - other <&> \accInfo -> - if Blockfrost._accountInfoActive accInfo - then - Just $ - GYStakeAddressInfo - { gyStakeAddressInfoDelegatedPool = Blockfrost._accountInfoPoolId accInfo >>= stakePoolIdFromTextMaybe . Blockfrost.unPoolId - , gyStakeAddressInfoAvailableRewards = fromInteger $ lovelacesToInteger $ Blockfrost._accountInfoWithdrawableAmount accInfo - } - else Nothing + where + -- This particular error is fine. + handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing + handler other = + handleBlockfrostError "Account" $ + other <&> \accInfo -> + if Blockfrost._accountInfoActive accInfo + then + Just $ + GYStakeAddressInfo + { gyStakeAddressInfoDelegatedPool = Blockfrost._accountInfoPoolId accInfo >>= stakePoolIdFromTextMaybe . Blockfrost.unPoolId + , gyStakeAddressInfoAvailableRewards = fromInteger $ lovelacesToInteger $ Blockfrost._accountInfoWithdrawableAmount accInfo + } + else Nothing ------------------------------------------------------------------------------- -- Auxiliary functions @@ -599,12 +599,12 @@ datumFromBlockfrostCBOR d = do bs <- fromEither $ BS16.decode $ Text.encodeUtf8 t api <- fromEither $ Api.deserialiseFromCBOR Api.AsHashableScriptData bs return $ datumFromApi' api - where - t = Blockfrost._scriptDatumCborCbor d - e = DeserializeErrorHex t + where + t = Blockfrost._scriptDatumCborCbor d + e = DeserializeErrorHex t - fromEither :: Either e a -> Either SomeDeserializeError a - fromEither = first $ const e + fromEither :: Either e a -> Either SomeDeserializeError a + fromEither = first $ const e outDatumFromBlockfrost :: Maybe Blockfrost.DatumHash -> Maybe Blockfrost.InlineDatum -> Either SomeDeserializeError GYOutDatum outDatumFromBlockfrost mdh mind = do diff --git a/src/GeniusYield/Providers/Common.hs b/src/GeniusYield/Providers/Common.hs index 0f521ba2..19f48966 100644 --- a/src/GeniusYield/Providers/Common.hs +++ b/src/GeniusYield/Providers/Common.hs @@ -93,8 +93,8 @@ data SomeDeserializeError deriving stock (Eq, Show) newtype SubmitTxException = SubmitTxException Text - deriving stock (Show) - deriving anyclass (Exception) + deriving stock Show + deriving anyclass Exception -- FIXME: Temporary, until remote providers us with it. plutusV3CostModels :: [Char] -> (Ledger.Language, Ledger.CostModel) @@ -137,8 +137,8 @@ populateMissingProtocolParameters nid pp = , cppDRepActivity = THKD $ Ledger.EpochInterval 20 , cppMinFeeRefScriptCostPerByte = THKD $ unsafeBoundRational 15 } - where - commonPoolVotingThreshold = unsafeBoundRational (51 % 100) + where + commonPoolVotingThreshold = unsafeBoundRational (51 % 100) -- | Get datum from bytes. datumFromCBOR :: Text -> Either SomeDeserializeError GYDatum @@ -146,11 +146,11 @@ datumFromCBOR d = do bs <- fromEither $ BS16.decode $ Text.encodeUtf8 d api <- fromEither $ Api.deserialiseFromCBOR Api.AsHashableScriptData bs return $ datumFromApi' api - where - e = DeserializeErrorHex d + where + e = DeserializeErrorHex d - fromEither :: Either e a -> Either SomeDeserializeError a - fromEither = first $ const e + fromEither :: Either e a -> Either SomeDeserializeError a + fromEither = first $ const e {- | Remove request headers info from returned ClientError. @@ -170,7 +170,7 @@ newServantClientEnv baseUrl = do else HttpClient.newManager HttpClient.defaultManagerSettings pure $ Servant.mkClientEnv manager url -fromJson :: (FromData a) => LBS.ByteString -> Either SomeDeserializeError a +fromJson :: FromData a => LBS.ByteString -> Either SomeDeserializeError a fromJson b = do v <- first (DeserializeErrorAeson . Text.pack) $ Aeson.eitherDecode b x <- first DeserializeErrorScriptDataJson $ Api.scriptDataFromJson Api.ScriptDataJsonDetailedSchema v @@ -220,43 +220,43 @@ preprodEraHist = . NonEmptyCons maryEra . NonEmptyCons alonzoEra $ NonEmptyOne babbageEra - where - byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} - } - shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 0} - } - babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + where + byronEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} + } + shelleyEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + allegraEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + maryEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + alonzoEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 0} + } + babbageEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } previewEraHist :: Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) previewEraHist = @@ -268,43 +268,43 @@ previewEraHist = . NonEmptyCons maryEra . NonEmptyCons alonzoEra $ NonEmptyOne babbageEra - where - byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} - } - shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } + where + byronEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} + } + shelleyEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + allegraEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + maryEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + alonzoEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + babbageEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } mainnetEraHist :: Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) mainnetEraHist = @@ -316,43 +316,43 @@ mainnetEraHist = . NonEmptyCons maryEra . NonEmptyCons alonzoEra $ NonEmptyOne babbageEra - where - byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} - } - shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + where + byronEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} + } + shelleyEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + allegraEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + maryEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + alonzoEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + babbageEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } -- | Extract currency symbol & token name part of an `GYAssetClass` when it is of such a form. When input is @Just GYLovelace@ or @Nothing@, this function returns @Nothing@. extractAssetClass :: Maybe GYAssetClass -> Maybe (Text, Text) diff --git a/src/GeniusYield/Providers/GCP.hs b/src/GeniusYield/Providers/GCP.hs index ae7b8064..29a5ecbb 100644 --- a/src/GeniusYield/Providers/GCP.hs +++ b/src/GeniusYield/Providers/GCP.hs @@ -18,7 +18,7 @@ import Katip.Scribes.Handle import GeniusYield.Imports -gcpFormatter :: (LogItem a) => ItemFormatter a +gcpFormatter :: LogItem a => ItemFormatter a gcpFormatter withColor verb @@ -36,17 +36,17 @@ gcpFormatter LTxt.toStrict $ lazyDecodeUtf8Lenient $ Aeson.encode obj - where - obj = - Aeson.object - [ "severity" .= toGCPSeverity severity - , "message" .= TxtB.toLazyText msgBuilder - , "extraPayload" .= payloadObject verb payload - , "time" .= time - , "threadId" .= tid - , "logging.googleapis.com/sourceLocation" .= (toGCPLoc <$> locMaybe) - , "logging.googleapis.com/labels" .= Aeson.object ["namespaces" .= namespaces] - ] + where + obj = + Aeson.object + [ "severity" .= toGCPSeverity severity + , "message" .= TxtB.toLazyText msgBuilder + , "extraPayload" .= payloadObject verb payload + , "time" .= time + , "threadId" .= tid + , "logging.googleapis.com/sourceLocation" .= (toGCPLoc <$> locMaybe) + , "logging.googleapis.com/labels" .= Aeson.object ["namespaces" .= namespaces] + ] toGCPLoc :: Loc -> Value toGCPLoc Loc {loc_filename, loc_package, loc_module, loc_start = (!lineNum, _)} = diff --git a/src/GeniusYield/Providers/Kupo.hs b/src/GeniusYield/Providers/Kupo.hs index 6a2b9209..39c485a0 100644 --- a/src/GeniusYield/Providers/Kupo.hs +++ b/src/GeniusYield/Providers/Kupo.hs @@ -107,7 +107,7 @@ data KupoProviderException | -- | Received an absurd response from Kupo. This shouldn't ever happen. KupoAbsurdResponse !Text deriving stock (Eq, Show) - deriving anyclass (Exception) + deriving anyclass Exception {-# INLINEABLE handleKupoError #-} handleKupoError :: Text -> Either ClientError a -> IO a @@ -157,7 +157,7 @@ instance FromJSON KupoDatum where data KupoScriptLanguage = Native | PlutusV1 | PlutusV2 | PlutusV3 deriving stock (Eq, Ord, Show, Generic) - deriving (FromJSON) via CustomJSON '[ConstructorTagModifier '[Rename "Native" "native", Rename "PlutusV1" "plutus:v1", Rename "PlutusV2" "plutus:v2", Rename "PlutusV3" "plutus:v3"]] KupoScriptLanguage + deriving FromJSON via CustomJSON '[ConstructorTagModifier '[Rename "Native" "native", Rename "PlutusV1" "plutus:v1", Rename "PlutusV2" "plutus:v2", Rename "PlutusV3" "plutus:v3"]] KupoScriptLanguage newtype KupoScript = KupoScript (Maybe GYAnyScript) deriving stock (Eq, Show, Generic) @@ -215,13 +215,13 @@ instance FromJSON KupoValue where data KupoDatumType = Hash | Inline deriving stock (Show, Eq, Ord, Generic) - deriving (FromJSON) via CustomJSON '[ConstructorTagModifier '[LowerFirst]] KupoDatumType + deriving FromJSON via CustomJSON '[ConstructorTagModifier '[LowerFirst]] KupoDatumType newtype KupoCreatedAt = KupoCreatedAt { slotNo :: Word64 } deriving stock (Show, Eq, Ord, Generic) - deriving (FromJSON) via CustomJSON '[FieldLabelModifier '[CamelToSnake]] KupoCreatedAt + deriving FromJSON via CustomJSON '[FieldLabelModifier '[CamelToSnake]] KupoCreatedAt data KupoUtxo = KupoUtxo { transactionId :: !GYTxId @@ -234,7 +234,7 @@ data KupoUtxo = KupoUtxo , createdAt :: !KupoCreatedAt } deriving stock (Show, Eq, Ord, Generic) - deriving (FromJSON) via CustomJSON '[FieldLabelModifier '[CamelToSnake]] KupoUtxo + deriving FromJSON via CustomJSON '[FieldLabelModifier '[CamelToSnake]] KupoUtxo findDatumByHash :: GYDatumHash -> ClientM KupoDatum findScriptByHash :: GYScriptHash -> ClientM KupoScript @@ -285,8 +285,8 @@ kupoUtxosAtAddress env addr mAssetClass = do Nothing -> commonRequestPart Nothing Nothing Just (mp, tn) -> commonRequestPart (Just mp) (Just tn) utxosFromList <$> traverse (transformUtxo env) (getResponse addrUtxos) - where - locationIdent = "AddressesUtxo" + where + locationIdent = "AddressesUtxo" kupoUtxoAtTxOutRef :: KupoApiEnv -> GYTxOutRef -> IO (Maybe GYUTxO) kupoUtxoAtTxOutRef env oref = do @@ -295,8 +295,8 @@ kupoUtxoAtTxOutRef env oref = do handleKupoError locationIdent <=< runKupoClient env $ fetchUtxosByPattern (Text.pack (show utxoIdx) <> "@" <> txId) True Nothing Nothing listToMaybe <$> traverse (transformUtxo env) (getResponse utxo) - where - locationIdent = "UtxoByRef" + where + locationIdent = "UtxoByRef" kupoUtxosAtPaymentCredential :: KupoApiEnv -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs kupoUtxosAtPaymentCredential env cred mAssetClass = do @@ -308,8 +308,8 @@ kupoUtxosAtPaymentCredential env cred mAssetClass = do Nothing -> commonRequestPart Nothing Nothing Just (mp, tn) -> commonRequestPart (Just mp) (Just tn) utxosFromList <$> traverse (transformUtxo env) (getResponse credUtxos) - where - locationIdent = "PaymentCredentialUtxos" + where + locationIdent = "PaymentCredentialUtxos" transformUtxo :: KupoApiEnv -> KupoUtxo -> IO GYUTxO transformUtxo env KupoUtxo {..} = do @@ -334,9 +334,9 @@ transformUtxo env KupoUtxo {..} = do , utxoOutDatum = dat , utxoRefScript = sc } - where - locationIdent = "transformUtxo" - commonDatumHashError = "No 'datum_hash' present in response whereas 'datum_type' mentions " + where + locationIdent = "transformUtxo" + commonDatumHashError = "No 'datum_hash' present in response whereas 'datum_type' mentions " -- | Definition of 'GYQueryUTxO' for the Kupo provider. kupoQueryUtxo :: KupoApiEnv -> GYQueryUTxO @@ -358,19 +358,19 @@ kupoQueryUtxo env = kupoAwaitTxConfirmed :: KupoApiEnv -> GYAwaitTx kupoAwaitTxConfirmed env p@GYAwaitTxParameters {..} txId = go 0 - where - go attempt - | attempt >= maxAttempts = throwIO $ GYAwaitTxException p - | otherwise = do - utxos <- - handleKupoError locationIdent <=< runKupoClient env $ - fetchUtxosByPattern (Text.pack $ "*@" <> show txId) False Nothing Nothing -- We don't require for only @unspent@. Kupo with @--prune-utxo@ option would still keep spent UTxOs until their spent record is truly immutable (see Kupo docs for more details). - case listToMaybe (getResponse utxos) of - Nothing -> threadDelay checkInterval >> go (attempt + 1) - Just u -> do - let slotsToWait = 3 * confirmations * 20 -- Ouroboros Praos guarantees that there are at least @k@ blocks in a window of @3k / f@ slots where @f@ is the active slot coefficient, which is @0.05@ for Mainnet, Preprod & Preview. - case (lookupResponseHeader utxos :: ResponseHeader "X-Most-Recent-Checkpoint" Word64) of - Header slotOfCurrentBlock -> unless (slotNo (createdAt u) + slotsToWait <= slotOfCurrentBlock) $ threadDelay checkInterval >> go (attempt + 1) - _ -> handleKupoAbsurdResponse locationIdent "Header 'X-Most-Recent-Checkpoint' isn't seen in response" - where - locationIdent = "AwaitTx" + where + go attempt + | attempt >= maxAttempts = throwIO $ GYAwaitTxException p + | otherwise = do + utxos <- + handleKupoError locationIdent <=< runKupoClient env $ + fetchUtxosByPattern (Text.pack $ "*@" <> show txId) False Nothing Nothing -- We don't require for only @unspent@. Kupo with @--prune-utxo@ option would still keep spent UTxOs until their spent record is truly immutable (see Kupo docs for more details). + case listToMaybe (getResponse utxos) of + Nothing -> threadDelay checkInterval >> go (attempt + 1) + Just u -> do + let slotsToWait = 3 * confirmations * 20 -- Ouroboros Praos guarantees that there are at least @k@ blocks in a window of @3k / f@ slots where @f@ is the active slot coefficient, which is @0.05@ for Mainnet, Preprod & Preview. + case (lookupResponseHeader utxos :: ResponseHeader "X-Most-Recent-Checkpoint" Word64) of + Header slotOfCurrentBlock -> unless (slotNo (createdAt u) + slotsToWait <= slotOfCurrentBlock) $ threadDelay checkInterval >> go (attempt + 1) + _ -> handleKupoAbsurdResponse locationIdent "Header 'X-Most-Recent-Checkpoint' isn't seen in response" + where + locationIdent = "AwaitTx" diff --git a/src/GeniusYield/Providers/LiteChainIndex.hs b/src/GeniusYield/Providers/LiteChainIndex.hs index 17ecf4cf..52e1d863 100644 --- a/src/GeniusYield/Providers/LiteChainIndex.hs +++ b/src/GeniusYield/Providers/LiteChainIndex.hs @@ -128,15 +128,15 @@ withChainSync :: (Async.Async () -> IO r) -> IO r withChainSync info resumePoints callback = Async.withAsync (Api.connectToLocalNode info localNodeClientProtocols) - where - localNodeClientProtocols :: Api.LocalNodeClientProtocolsInMode - localNodeClientProtocols = - Api.LocalNodeClientProtocols - { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback - , localTxSubmissionClient = Nothing - , localStateQueryClient = Nothing - , localTxMonitoringClient = Nothing - } + where + localNodeClientProtocols :: Api.LocalNodeClientProtocolsInMode + localNodeClientProtocols = + Api.LocalNodeClientProtocols + { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback + , localTxSubmissionClient = Nothing + , localStateQueryClient = Nothing + , localTxMonitoringClient = Nothing + } newChainSync :: Api.LocalNodeConnectInfo -> @@ -145,15 +145,15 @@ newChainSync :: IO (Async.Async ()) newChainSync info resumePoints callback = Async.async (Api.connectToLocalNode info localNodeClientProtocols) - where - localNodeClientProtocols :: Api.LocalNodeClientProtocolsInMode - localNodeClientProtocols = - Api.LocalNodeClientProtocols - { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback - , localTxSubmissionClient = Nothing - , localStateQueryClient = Nothing - , localTxMonitoringClient = Nothing - } + where + localNodeClientProtocols :: Api.LocalNodeClientProtocolsInMode + localNodeClientProtocols = + Api.LocalNodeClientProtocols + { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback + , localTxSubmissionClient = Nothing + , localStateQueryClient = Nothing + , localTxMonitoringClient = Nothing + } chainSyncClient :: [Api.ChainPoint] -> @@ -162,51 +162,51 @@ chainSyncClient :: chainSyncClient [] cb = chainSyncClient [Api.ChainPointAtGenesis] cb chainSyncClient resumePoints cb = Api.ChainSyncClient $ pure initialise - where - initialise = - Api.Sync.SendMsgFindIntersect resumePoints $ - Api.Sync.ClientStIntersect - { Api.Sync.recvMsgIntersectFound = \point _tip -> Api.ChainSyncClient $ do - cb (Resume point) - pure requestNext - , Api.Sync.recvMsgIntersectNotFound = \_tip -> - Api.ChainSyncClient $ pure requestNext - } - - requestNext :: Api.Sync.ClientStIdle Api.BlockInMode Api.ChainPoint Api.ChainTip IO () - requestNext = Api.Sync.SendMsgRequestNext (pure ()) handleNext - - handleNext = - Api.Sync.ClientStNext - { Api.Sync.recvMsgRollForward = \block tip -> Api.ChainSyncClient $ do - cb (RollForward block tip) - pure requestNext - , Api.Sync.recvMsgRollBackward = \point tip -> Api.ChainSyncClient $ do - cb (RollBackward point tip) + where + initialise = + Api.Sync.SendMsgFindIntersect resumePoints $ + Api.Sync.ClientStIntersect + { Api.Sync.recvMsgIntersectFound = \point _tip -> Api.ChainSyncClient $ do + cb (Resume point) pure requestNext + , Api.Sync.recvMsgIntersectNotFound = \_tip -> + Api.ChainSyncClient $ pure requestNext } + requestNext :: Api.Sync.ClientStIdle Api.BlockInMode Api.ChainPoint Api.ChainTip IO () + requestNext = Api.Sync.SendMsgRequestNext (pure ()) handleNext + + handleNext = + Api.Sync.ClientStNext + { Api.Sync.recvMsgRollForward = \block tip -> Api.ChainSyncClient $ do + cb (RollForward block tip) + pure requestNext + , Api.Sync.recvMsgRollBackward = \point tip -> Api.ChainSyncClient $ do + cb (RollBackward point tip) + pure requestNext + } + ------------------------------------------------------------------------------- -- Utilities ------------------------------------------------------------------------------- blockDatums :: Api.BlockInMode -> [Api.HashableScriptData] blockDatums (Api.BlockInMode _ block) = goBlock block - where - goBlock :: Api.Block era -> [Api.HashableScriptData] - goBlock (Api.Block _header txs) = concatMap goTx txs + where + goBlock :: Api.Block era -> [Api.HashableScriptData] + goBlock (Api.Block _header txs) = concatMap goTx txs - goTx :: Api.Tx era -> [Api.HashableScriptData] - goTx (Api.Tx (Api.TxBody body) _witnesses) = goTxBody body + goTx :: Api.Tx era -> [Api.HashableScriptData] + goTx (Api.Tx (Api.TxBody body) _witnesses) = goTxBody body - goTxBody :: Api.TxBodyContent Api.ViewTx era -> [Api.HashableScriptData] - goTxBody body = concatMap goTxOut (Api.txOuts body) + goTxBody :: Api.TxBodyContent Api.ViewTx era -> [Api.HashableScriptData] + goTxBody body = concatMap goTxOut (Api.txOuts body) - goTxOut :: Api.TxOut Api.CtxTx era -> [Api.HashableScriptData] - goTxOut (Api.TxOut _addr _value datum _) = goDatum datum + goTxOut :: Api.TxOut Api.CtxTx era -> [Api.HashableScriptData] + goTxOut (Api.TxOut _addr _value datum _) = goDatum datum - goDatum :: Api.TxOutDatum Api.CtxTx era -> [Api.HashableScriptData] - goDatum Api.TxOutDatumNone = [] - goDatum (Api.TxOutDatumInTx _ sd) = [sd] - goDatum (Api.TxOutDatumHash _ _h) = [] - goDatum (Api.TxOutDatumInline _ sd) = [sd] + goDatum :: Api.TxOutDatum Api.CtxTx era -> [Api.HashableScriptData] + goDatum Api.TxOutDatumNone = [] + goDatum (Api.TxOutDatumInTx _ sd) = [sd] + goDatum (Api.TxOutDatumHash _ _h) = [] + goDatum (Api.TxOutDatumInline _ sd) = [sd] diff --git a/src/GeniusYield/Providers/Maestro.hs b/src/GeniusYield/Providers/Maestro.hs index d67925a5..5b37aaf2 100644 --- a/src/GeniusYield/Providers/Maestro.hs +++ b/src/GeniusYield/Providers/Maestro.hs @@ -75,7 +75,7 @@ data MaestroProviderException | -- | The API returned an unexpected number of era summaries. MspvIncorrectEraHistoryLength ![Maestro.EraSummary] deriving stock (Eq, Show) - deriving anyclass (Exception) + deriving anyclass Exception throwMspvApiError :: Text -> Maestro.MaestroError -> IO a throwMspvApiError locationInfo = @@ -103,9 +103,9 @@ maestroSubmitTx useTurboSubmit env tx = do pure $ txIdFromHexE $ Text.unpack txId - where - handleMaestroSubmitError :: Either Maestro.MaestroError a -> IO a - handleMaestroSubmitError = either (throwIO . SubmitTxException . Text.pack . show . silenceHeadersMaestroClientError) pure + where + handleMaestroSubmitError :: Either Maestro.MaestroError a -> IO a + handleMaestroSubmitError = either (throwIO . SubmitTxException . Text.pack . show . silenceHeadersMaestroClientError) pure ------------------------------------------------------------------------------- -- Await tx confirmation @@ -114,44 +114,44 @@ maestroSubmitTx useTurboSubmit env tx = do -- | Awaits for the confirmation of a given 'GYTxId' maestroAwaitTxConfirmed :: Maestro.MaestroEnv 'Maestro.V1 -> GYAwaitTx maestroAwaitTxConfirmed env p@GYAwaitTxParameters {..} txId = mspvAwaitTx 0 - where - mspvAwaitTx :: Int -> IO () - mspvAwaitTx attempt | maxAttempts <= attempt = throwIO $ GYAwaitTxException p - mspvAwaitTx attempt = do - eTxInfo <- maestroQueryTx env txId - case eTxInfo of - Left Maestro.MaestroNotFound -> - threadDelay checkInterval - >> mspvAwaitTx (attempt + 1) - Left err -> throwMspvApiError "AwaitTx" err - Right txInfo -> - msvpAwaitBlock attempt $ - Maestro.txDetailsBlockHash $ - Maestro.getTimestampedData txInfo - - msvpAwaitBlock :: Int -> Maestro.BlockHash -> IO () - msvpAwaitBlock attempt _ | maxAttempts <= attempt = throwIO $ GYAwaitTxException p - msvpAwaitBlock attempt blockHash = do - eBlockInfo <- maestroQueryBlock env blockHash - case eBlockInfo of - Left Maestro.MaestroNotFound -> - threadDelay checkInterval - >> msvpAwaitBlock (attempt + 1) blockHash - Left err -> throwMspvApiError "AwaitBlock" err - Right (Maestro.getTimestampedData -> blockInfo) - | attempt + 1 == maxAttempts -> - when - ( toInteger (Maestro.blockDetailsConfirmations blockInfo) - < toInteger confirmations - ) - $ throwIO - $ GYAwaitTxException p - Right (Maestro.getTimestampedData -> blockInfo) -> - when - ( toInteger (Maestro.blockDetailsConfirmations blockInfo) - < toInteger confirmations - ) - $ threadDelay checkInterval >> msvpAwaitBlock (attempt + 1) blockHash + where + mspvAwaitTx :: Int -> IO () + mspvAwaitTx attempt | maxAttempts <= attempt = throwIO $ GYAwaitTxException p + mspvAwaitTx attempt = do + eTxInfo <- maestroQueryTx env txId + case eTxInfo of + Left Maestro.MaestroNotFound -> + threadDelay checkInterval + >> mspvAwaitTx (attempt + 1) + Left err -> throwMspvApiError "AwaitTx" err + Right txInfo -> + msvpAwaitBlock attempt $ + Maestro.txDetailsBlockHash $ + Maestro.getTimestampedData txInfo + + msvpAwaitBlock :: Int -> Maestro.BlockHash -> IO () + msvpAwaitBlock attempt _ | maxAttempts <= attempt = throwIO $ GYAwaitTxException p + msvpAwaitBlock attempt blockHash = do + eBlockInfo <- maestroQueryBlock env blockHash + case eBlockInfo of + Left Maestro.MaestroNotFound -> + threadDelay checkInterval + >> msvpAwaitBlock (attempt + 1) blockHash + Left err -> throwMspvApiError "AwaitBlock" err + Right (Maestro.getTimestampedData -> blockInfo) + | attempt + 1 == maxAttempts -> + when + ( toInteger (Maestro.blockDetailsConfirmations blockInfo) + < toInteger confirmations + ) + $ throwIO + $ GYAwaitTxException p + Right (Maestro.getTimestampedData -> blockInfo) -> + when + ( toInteger (Maestro.blockDetailsConfirmations blockInfo) + < toInteger confirmations + ) + $ threadDelay checkInterval >> msvpAwaitBlock (attempt + 1) blockHash maestroQueryBlock :: Maestro.MaestroEnv 'Maestro.V1 -> @@ -229,7 +229,7 @@ scriptFromMaestro Maestro.Script {..} = case scriptType of Just sb -> pure $ GYPlutusScript <$> scriptFromCBOR @'PlutusV3 sb -- | Convert Maestro's UTxO to our GY type. -utxoFromMaestro :: (Maestro.IsUtxo a) => a -> Either SomeDeserializeError GYUTxO +utxoFromMaestro :: Maestro.IsUtxo a => a -> Either SomeDeserializeError GYUTxO utxoFromMaestro utxo = do ref <- first DeserializeErrorHex . Web.parseUrlPiece $ Web.toUrlPiece (Maestro.getTxHash utxo) <> "#" <> Web.toUrlPiece (Maestro.getIndex utxo) addr <- maybeToRight DeserializeErrorAddress $ addressFromTextMaybe $ coerce $ Maestro.getAddress utxo @@ -246,7 +246,7 @@ utxoFromMaestro utxo = do } -- | Convert Maestro's UTxO (with datum resolved) to our GY types. -utxoFromMaestroWithDatum :: (Maestro.IsUtxo a) => a -> Either SomeDeserializeError (GYUTxO, Maybe GYDatum) +utxoFromMaestroWithDatum :: Maestro.IsUtxo a => a -> Either SomeDeserializeError (GYUTxO, Maybe GYDatum) utxoFromMaestroWithDatum u = do gyUtxo <- utxoFromMaestro u case utxoOutDatum gyUtxo of @@ -270,8 +270,8 @@ maestroUtxosAtAddress env addr mAssetClass = do addrUtxos <- handleMaestroError locationIdent <=< try $ Maestro.allPages (Maestro.utxosAtAddress env (coerce addrAsText) (Just False) (Just False) (extractedAssetClassToMaestro extractedAssetClass)) either (throwIO . MspvDeserializeFailure locationIdent) (pure . utxosFromList) (traverse utxoFromMaestro addrUtxos) - where - locationIdent = "AddressUtxos" + where + locationIdent = "AddressUtxos" -- | Query UTxOs present at given address with datums. maestroUtxosAtAddressWithDatums :: Maestro.MaestroEnv 'Maestro.V1 -> GYAddress -> Maybe GYAssetClass -> IO [(GYUTxO, Maybe GYDatum)] @@ -285,8 +285,8 @@ maestroUtxosAtAddressWithDatums env addr mAssetClass = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestroWithDatum addrUtxos - where - locationIdent = "AddressUtxosWithDatums" + where + locationIdent = "AddressUtxosWithDatums" -- | Query UTxOs present at multiple addresses. maestroUtxosAtAddresses :: Maestro.MaestroEnv 'Maestro.V1 -> [GYAddress] -> IO GYUTxOs @@ -296,8 +296,8 @@ maestroUtxosAtAddresses env addrs = do addrUtxos <- handleMaestroError locationIdent <=< try $ Maestro.allPages (flip (Maestro.utxosAtMultiAddresses env (Just False) (Just False)) $ coerce addrsInText) either (throwIO . MspvDeserializeFailure locationIdent) (pure . utxosFromList) (traverse utxoFromMaestro addrUtxos) - where - locationIdent = "AddressesUtxos" + where + locationIdent = "AddressesUtxos" -- | Query UTxOs present at multiple addresses with datums. maestroUtxosAtAddressesWithDatums :: Maestro.MaestroEnv 'Maestro.V1 -> [GYAddress] -> IO [(GYUTxO, Maybe GYDatum)] @@ -310,8 +310,8 @@ maestroUtxosAtAddressesWithDatums env addrs = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestroWithDatum addrUtxos - where - locationIdent = "AddressesUtxosWithDatums" + where + locationIdent = "AddressesUtxosWithDatums" -- | Query UTxOs present at payment credential. maestroUtxosAtPaymentCredential :: Maestro.MaestroEnv 'Maestro.V1 -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs @@ -322,8 +322,8 @@ maestroUtxosAtPaymentCredential env paymentCredential mAssetClass = do utxos <- handleMaestroError locationIdent <=< try $ Maestro.allPages $ Maestro.utxosByPaymentCredential env paymentCredentialBech32 (Just False) (Just False) (extractedAssetClassToMaestro extractedAssetClass) either (throwIO . MspvDeserializeFailure locationIdent) (pure . utxosFromList) (traverse utxoFromMaestro utxos) - where - locationIdent = "PaymentCredentialUtxos" + where + locationIdent = "PaymentCredentialUtxos" -- | Query UTxOs present at payment credential with their associated datum fetched (under best effort basis). maestroUtxosAtPaymentCredentialWithDatums :: Maestro.MaestroEnv 'Maestro.V1 -> GYPaymentCredential -> Maybe GYAssetClass -> IO [(GYUTxO, Maybe GYDatum)] @@ -337,8 +337,8 @@ maestroUtxosAtPaymentCredentialWithDatums env paymentCredential mAssetClass = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestroWithDatum utxos - where - locationIdent = "PaymentCredentialUtxosWithDatums" + where + locationIdent = "PaymentCredentialUtxosWithDatums" -- | Query UTxOs present at multiple payment credentials. maestroUtxosAtPaymentCredentials :: Maestro.MaestroEnv 'Maestro.V1 -> [GYPaymentCredential] -> IO GYUTxOs @@ -348,8 +348,8 @@ maestroUtxosAtPaymentCredentials env pcs = do utxos <- handleMaestroError locationIdent <=< try $ Maestro.allPages (flip (Maestro.utxosByMultiPaymentCredentials env (Just False) (Just False)) $ coerce paymentCredentialsBech32) either (throwIO . MspvDeserializeFailure locationIdent) (pure . utxosFromList) (traverse utxoFromMaestro utxos) - where - locationIdent = "PaymentCredentialsUtxos" + where + locationIdent = "PaymentCredentialsUtxos" -- | Query UTxOs present at multiple payment credentials with datums. maestroUtxosAtPaymentCredentialsWithDatums :: Maestro.MaestroEnv 'Maestro.V1 -> [GYPaymentCredential] -> IO [(GYUTxO, Maybe GYDatum)] @@ -362,8 +362,8 @@ maestroUtxosAtPaymentCredentialsWithDatums env pcs = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestroWithDatum utxos - where - locationIdent = "PaymentCredentialsUtxosWithDatums" + where + locationIdent = "PaymentCredentialsUtxosWithDatums" -- | Returns a list containing all 'GYTxOutRef' for a given 'GYAddress'. maestroRefsAtAddress :: Maestro.MaestroEnv 'Maestro.V1 -> GYAddress -> IO [GYTxOutRef] @@ -378,8 +378,8 @@ maestroRefsAtAddress env addr = do Web.parseUrlPiece $ Web.toUrlPiece outputReferenceObjectTxHash <> "#" <> Web.toUrlPiece outputReferenceObjectIndex ) mTxRefs - where - locationIdent = "RefsAtAddress" + where + locationIdent = "RefsAtAddress" -- | Query UTxO present at a output reference. maestroUtxoAtTxOutRef :: Maestro.MaestroEnv 'Maestro.V1 -> GYTxOutRef -> IO (Maybe GYUTxO) @@ -411,12 +411,12 @@ maestroUtxosAtTxOutRefs' env refs = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestro res - where - -- This particular error is fine in this case, we can just return @mempty@. - handler (Left Maestro.MaestroNotFound) = pure [] - handler other = handleMaestroError locationIdent other + where + -- This particular error is fine in this case, we can just return @mempty@. + handler (Left Maestro.MaestroNotFound) = pure [] + handler other = handleMaestroError locationIdent other - locationIdent = "UtxoByRefs" + locationIdent = "UtxoByRefs" -- | Query UTxOs present at multiple `GYTxOutRef` with datums. maestroUtxosAtTxOutRefsWithDatums :: Maestro.MaestroEnv 'Maestro.V1 -> [GYTxOutRef] -> IO [(GYUTxO, Maybe GYDatum)] @@ -429,12 +429,12 @@ maestroUtxosAtTxOutRefsWithDatums env refs = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestroWithDatum res - where - -- This particular error is fine in this case, we can just return @mempty@. - handler (Left Maestro.MaestroNotFound) = pure [] - handler other = handleMaestroError locationIdent other + where + -- This particular error is fine in this case, we can just return @mempty@. + handler (Left Maestro.MaestroNotFound) = pure [] + handler other = handleMaestroError locationIdent other - locationIdent = "UtxoByRefsWithDatums" + locationIdent = "UtxoByRefsWithDatums" -- | Definition of 'GYQueryUTxO' for the Maestro provider. maestroQueryUtxo :: Maestro.MaestroEnv 'Maestro.V1 -> GYQueryUTxO @@ -535,8 +535,8 @@ maestroProtocolParams nid env = do , cppDRepActivity = THKD (Ledger.EpochInterval 0) , cppMinFeeRefScriptCostPerByte = THKD minBound } - where - errPath = "GeniusYield.Providers.Maestro.maestroProtocolParams: " + where + errPath = "GeniusYield.Providers.Maestro.maestroProtocolParams: " -- | Returns a set of all Stake Pool's 'Api.S.PoolId'. maestroStakePools :: Maestro.MaestroEnv 'Maestro.V1 -> IO (Set Api.S.PoolId) @@ -552,8 +552,8 @@ maestroStakePools env = do -- Deserialization failure shouldn't happen on Maestro returned pool id. Left err -> throwIO . MspvDeserializeFailure locationIdent $ DeserializeErrorBech32 err Right has -> pure $ Set.fromList has - where - locationIdent = "ListPools" + where + locationIdent = "ListPools" -- | Returns the 'CTime.SystemStart' queried from Maestro. maestroSystemStart :: Maestro.MaestroEnv 'Maestro.V1 -> IO CTime.SystemStart @@ -567,26 +567,26 @@ maestroEraHistory :: Maestro.MaestroEnv 'Maestro.V1 -> IO Api.EraHistory maestroEraHistory env = do eraSumms <- handleMaestroError "EraHistory" =<< try (Maestro.getTimestampedData <$> Maestro.getEraHistory env) maybe (throwIO $ MspvIncorrectEraHistoryLength eraSumms) pure $ parseEraHist mkEra eraSumms - where - mkBound Maestro.EraBound {eraBoundEpoch, eraBoundSlot, eraBoundTime} = - Ouroboros.Bound - { boundTime = CTime.RelativeTime $ Maestro.eraBoundTimeSeconds eraBoundTime - , boundSlot = CSlot.SlotNo $ fromIntegral eraBoundSlot - , boundEpoch = CSlot.EpochNo $ fromIntegral eraBoundEpoch - } - mkEraParams Maestro.EraParameters {eraParametersEpochLength, eraParametersSlotLength, eraParametersSafeZone} = - Ouroboros.EraParams - { eraEpochSize = CSlot.EpochSize $ fromIntegral eraParametersEpochLength - , eraSlotLength = CTime.mkSlotLength $ Maestro.epochSlotLengthMilliseconds eraParametersSlotLength / 1000 - , eraSafeZone = Ouroboros.StandardSafeZone $ fromJust eraParametersSafeZone - , eraGenesisWin = fromIntegral $ fromJust eraParametersSafeZone -- TODO: Get it from provider? It is supposed to be 3k/f where k is security parameter (at present 2160) and f is active slot coefficient. Usually ledger set the safe zone size such that it guarantees at least k blocks... - } - mkEra Maestro.EraSummary {eraSummaryStart, eraSummaryEnd, eraSummaryParameters} = - Ouroboros.EraSummary - { eraStart = mkBound eraSummaryStart - , eraEnd = maybe Ouroboros.EraUnbounded (Ouroboros.EraEnd . mkBound) eraSummaryEnd - , eraParams = mkEraParams eraSummaryParameters - } + where + mkBound Maestro.EraBound {eraBoundEpoch, eraBoundSlot, eraBoundTime} = + Ouroboros.Bound + { boundTime = CTime.RelativeTime $ Maestro.eraBoundTimeSeconds eraBoundTime + , boundSlot = CSlot.SlotNo $ fromIntegral eraBoundSlot + , boundEpoch = CSlot.EpochNo $ fromIntegral eraBoundEpoch + } + mkEraParams Maestro.EraParameters {eraParametersEpochLength, eraParametersSlotLength, eraParametersSafeZone} = + Ouroboros.EraParams + { eraEpochSize = CSlot.EpochSize $ fromIntegral eraParametersEpochLength + , eraSlotLength = CTime.mkSlotLength $ Maestro.epochSlotLengthMilliseconds eraParametersSlotLength / 1000 + , eraSafeZone = Ouroboros.StandardSafeZone $ fromJust eraParametersSafeZone + , eraGenesisWin = fromIntegral $ fromJust eraParametersSafeZone -- TODO: Get it from provider? It is supposed to be 3k/f where k is security parameter (at present 2160) and f is active slot coefficient. Usually ledger set the safe zone size such that it guarantees at least k blocks... + } + mkEra Maestro.EraSummary {eraSummaryStart, eraSummaryEnd, eraSummaryParameters} = + Ouroboros.EraSummary + { eraStart = mkBound eraSummaryStart + , eraEnd = maybe Ouroboros.EraUnbounded (Ouroboros.EraEnd . mkBound) eraSummaryEnd + , eraParams = mkEraParams eraSummaryParameters + } ------------------------------------------------------------------------------- -- Datum lookup @@ -602,11 +602,11 @@ maestroLookupDatum env dh = do Right bd -> pure bd ) datumMaybe - where - locationIdent = "LookupDatum" - -- This particular error is fine in this case, we can just return 'Nothing'. - handler (Left Maestro.MaestroNotFound) = pure Nothing - handler other = handleMaestroError locationIdent $ Just <$> other + where + locationIdent = "LookupDatum" + -- This particular error is fine in this case, we can just return 'Nothing'. + handler (Left Maestro.MaestroNotFound) = pure Nothing + handler other = handleMaestroError locationIdent $ Just <$> other ------------------------------------------------------------------------------- -- Account info @@ -616,17 +616,17 @@ maestroLookupDatum env dh = do maestroStakeAddressInfo :: Maestro.MaestroEnv 'Maestro.V1 -> GYStakeAddress -> IO (Maybe GYStakeAddressInfo) maestroStakeAddressInfo env saddr = do handler <=< try $ Maestro.getTimestampedData <$> Maestro.accountInfo env (coerce stakeAddressToText saddr) - where - -- This particular error is fine. - handler (Left Maestro.MaestroNotFound) = pure Nothing - handler other = - handleMaestroError "AccountInfo" $ - other <&> \accInfo -> - if Maestro.accountInfoRegistered accInfo - then - Just $ - GYStakeAddressInfo - { gyStakeAddressInfoDelegatedPool = Maestro.accountInfoDelegatedPool accInfo >>= stakePoolIdFromTextMaybe . coerce - , gyStakeAddressInfoAvailableRewards = fromIntegral $ Maestro.accountInfoRewardsAvailable accInfo - } - else Nothing + where + -- This particular error is fine. + handler (Left Maestro.MaestroNotFound) = pure Nothing + handler other = + handleMaestroError "AccountInfo" $ + other <&> \accInfo -> + if Maestro.accountInfoRegistered accInfo + then + Just $ + GYStakeAddressInfo + { gyStakeAddressInfoDelegatedPool = Maestro.accountInfoDelegatedPool accInfo >>= stakePoolIdFromTextMaybe . coerce + , gyStakeAddressInfoAvailableRewards = fromIntegral $ Maestro.accountInfoRewardsAvailable accInfo + } + else Nothing diff --git a/src/GeniusYield/Providers/Node.hs b/src/GeniusYield/Providers/Node.hs index 01e61bc0..9b4a840e 100644 --- a/src/GeniusYield/Providers/Node.hs +++ b/src/GeniusYield/Providers/Node.hs @@ -61,8 +61,8 @@ nodeSlotActions info = , gyWaitForNextBlock' = gyWaitForNextBlockDefault getSlotOfCurrentBlock , gyWaitUntilSlot' = gyWaitUntilSlotDefault getSlotOfCurrentBlock } - where - getSlotOfCurrentBlock = nodeGetSlotOfCurrentBlock info + where + getSlotOfCurrentBlock = nodeGetSlotOfCurrentBlock info ------------------------------------------------------------------------------- -- Parameters diff --git a/src/GeniusYield/Providers/Node/AwaitTx.hs b/src/GeniusYield/Providers/Node/AwaitTx.hs index 5862abac..6efb307f 100644 --- a/src/GeniusYield/Providers/Node/AwaitTx.hs +++ b/src/GeniusYield/Providers/Node/AwaitTx.hs @@ -38,21 +38,21 @@ See: https://docs.cardano.org/about-cardano/learn/chain-confirmation-versus-tran -} nodeAwaitTxConfirmed :: Api.LocalNodeConnectInfo -> GYAwaitTx nodeAwaitTxConfirmed info p@GYAwaitTxParameters {..} txId = go 0 - where - go attempt - | attempt >= maxAttempts = throwIO $ GYAwaitTxException p - | otherwise = do - {- NOTE: Checking for created utxos is not always correct. + where + go attempt + | attempt >= maxAttempts = throwIO $ GYAwaitTxException p + | otherwise = do + {- NOTE: Checking for created utxos is not always correct. - Transactions that create stake deposit with a user who's remaining - utxos are only enough to cover the transaction cost, create no outputs. - However, this is an extreme edge case that is unlikely to ever exist in - privnet tests (where this module is meant to be used, exclusively). - -} - utxos <- nodeUtxosFromTx info txId - -- FIXME: This doesn't actually wait for confirmations. - unless (utxosSize utxos /= 0) $ - threadDelay checkInterval >> go (attempt + 1) + Transactions that create stake deposit with a user who's remaining + utxos are only enough to cover the transaction cost, create no outputs. + However, this is an extreme edge case that is unlikely to ever exist in + privnet tests (where this module is meant to be used, exclusively). + -} + utxos <- nodeUtxosFromTx info txId + -- FIXME: This doesn't actually wait for confirmations. + unless (utxosSize utxos /= 0) $ + threadDelay checkInterval >> go (attempt + 1) -- | Obtain UTxOs created by a transaction. nodeUtxosFromTx :: Api.LocalNodeConnectInfo -> GYTxId -> IO GYUTxOs @@ -72,10 +72,10 @@ nodeUtxosFromTx info txId = do let startIx = 0 uptoIx = 10 go mempty startIx uptoIx - where - go acc startIx uptoIx = do - utxos <- nodeUtxosAtTxOutRefs info $ curry txOutRefFromTuple txId <$> [startIx .. uptoIx] - let acc' = acc <> utxos - if utxosSize utxos == 0 - then pure acc' - else go acc' (uptoIx + 1) (uptoIx * 2) + where + go acc startIx uptoIx = do + utxos <- nodeUtxosAtTxOutRefs info $ curry txOutRefFromTuple txId <$> [startIx .. uptoIx] + let acc' = acc <> utxos + if utxosSize utxos == 0 + then pure acc' + else go acc' (uptoIx + 1) (uptoIx * 2) diff --git a/src/GeniusYield/Providers/Node/Query.hs b/src/GeniusYield/Providers/Node/Query.hs index 309729b3..17cd16ef 100644 --- a/src/GeniusYield/Providers/Node/Query.hs +++ b/src/GeniusYield/Providers/Node/Query.hs @@ -64,10 +64,10 @@ nodeUtxosAtPaymentCredentials :: Api.LocalNodeConnectInfo -> [GYPaymentCredentia nodeUtxosAtPaymentCredentials info creds = do allUtxos <- queryUTxO info Api.QueryUTxOWhole pure $ filterUTxOs (\GYUTxO {utxoAddress} -> matchesCred $ addressToPaymentCredential utxoAddress) allUtxos - where - credSet = Set.fromList creds - matchesCred Nothing = False - matchesCred (Just cred) = cred `Set.member` credSet + where + credSet = Set.fromList creds + matchesCred Nothing = False + matchesCred (Just cred) = cred `Set.member` credSet nodeQueryUTxO :: Api.S.LocalNodeConnectInfo -> GYQueryUTxO nodeQueryUTxO info = diff --git a/src/GeniusYield/Providers/Sentry.hs b/src/GeniusYield/Providers/Sentry.hs index 155b97b7..f58d78dc 100644 --- a/src/GeniusYield/Providers/Sentry.hs +++ b/src/GeniusYield/Providers/Sentry.hs @@ -26,51 +26,51 @@ import System.Log.Raven.Types qualified as Raven mkSentryScribe :: Raven.SentryService -> Katip.PermitFunc -> Katip.Verbosity -> IO Katip.Scribe mkSentryScribe ss pf vb = return $ Katip.Scribe logger (return ()) pf - where - logger :: (Katip.LogItem a) => Katip.Item a -> IO () - logger item = do - let lvl = sentryLevel $ Katip._itemSeverity item - msg = TL.unpack $ Builder.toLazyText $ Katip.unLogStr $ Katip._itemMessage item - nmSpace = sentryNamespace $ Katip._itemNamespace item + where + logger :: Katip.LogItem a => Katip.Item a -> IO () + logger item = do + let lvl = sentryLevel $ Katip._itemSeverity item + msg = TL.unpack $ Builder.toLazyText $ Katip.unLogStr $ Katip._itemMessage item + nmSpace = sentryNamespace $ Katip._itemNamespace item - -- Register Sentry event - -- https://hackage.haskell.org/package/raven-haskell-0.1.4.1/docs/System-Log-Raven.html#v:register - Raven.register ss nmSpace lvl msg (`updateRecord` item) + -- Register Sentry event + -- https://hackage.haskell.org/package/raven-haskell-0.1.4.1/docs/System-Log-Raven.html#v:register + Raven.register ss nmSpace lvl msg (`updateRecord` item) - -- send Ktip.Loc data to sentry - locAttr :: (Katip.LogItem a) => Katip.Item a -> HashMap T.Text Aeson.Value - locAttr item = foldMap (HM.singleton "loc" . Aeson.toJSON . Katip.Core.LocJs) (Katip._itemLoc item) + -- send Ktip.Loc data to sentry + locAttr :: Katip.LogItem a => Katip.Item a -> HashMap T.Text Aeson.Value + locAttr item = foldMap (HM.singleton "loc" . Aeson.toJSON . Katip.Core.LocJs) (Katip._itemLoc item) - -- extra attributes we can send to sentry - srExtra :: (Katip.LogItem a) => Katip.Item a -> HashMap String Aeson.Value - srExtra item = toStringHashMap $ toHashMapText $ Katip.payloadObject vb (Katip._itemPayload item) <> fromHashMapText (locAttr item) - where - toStringHashMap :: HashMap T.Text Aeson.Value -> HashMap String Aeson.Value - toStringHashMap = HM.fromList . map (first T.unpack) . HM.toList + -- extra attributes we can send to sentry + srExtra :: Katip.LogItem a => Katip.Item a -> HashMap String Aeson.Value + srExtra item = toStringHashMap $ toHashMapText $ Katip.payloadObject vb (Katip._itemPayload item) <> fromHashMapText (locAttr item) + where + toStringHashMap :: HashMap T.Text Aeson.Value -> HashMap String Aeson.Value + toStringHashMap = HM.fromList . map (first T.unpack) . HM.toList - updateRecord :: (Katip.LogItem a) => Raven.SentryRecord -> Katip.Item a -> Raven.SentryRecord - updateRecord record item = - record - { Raven.srEnvironment = Just $ T.unpack $ Katip.getEnvironment $ Katip._itemEnv item - , Raven.srExtra = srExtra item - , Raven.srTimestamp = Katip._itemTime item - } + updateRecord :: Katip.LogItem a => Raven.SentryRecord -> Katip.Item a -> Raven.SentryRecord + updateRecord record item = + record + { Raven.srEnvironment = Just $ T.unpack $ Katip.getEnvironment $ Katip._itemEnv item + , Raven.srExtra = srExtra item + , Raven.srTimestamp = Katip._itemTime item + } - -- Sentry Level for Katip Log - sentryLevel :: Katip.Severity -> Raven.SentryLevel - sentryLevel Katip.DebugS = Raven.Debug - sentryLevel Katip.InfoS = Raven.Info - sentryLevel Katip.ErrorS = Raven.Error - sentryLevel Katip.WarningS = Raven.Warning - sentryLevel _ = Raven.Custom "Other" + -- Sentry Level for Katip Log + sentryLevel :: Katip.Severity -> Raven.SentryLevel + sentryLevel Katip.DebugS = Raven.Debug + sentryLevel Katip.InfoS = Raven.Info + sentryLevel Katip.ErrorS = Raven.Error + sentryLevel Katip.WarningS = Raven.Warning + sentryLevel _ = Raven.Custom "Other" - -- gives proper namespace for sentry - -- - -- >>> sentryNamespace $ Katip.Namespace ["GeniusYield", "Providers", "Logging"] - -- "GeniusYield.Providers.Logging" - -- - sentryNamespace :: Katip.Namespace -> String - sentryNamespace (Katip.Namespace ks) = T.unpack $ T.intercalate "." ks + -- gives proper namespace for sentry + -- + -- >>> sentryNamespace $ Katip.Namespace ["GeniusYield", "Providers", "Logging"] + -- "GeniusYield.Providers.Logging" + -- + sentryNamespace :: Katip.Namespace -> String + sentryNamespace (Katip.Namespace ks) = T.unpack $ T.intercalate "." ks -- minimum sentry service constructed from dsn sentryService :: String -> Raven.SentryService diff --git a/src/GeniusYield/ReadJSON.hs b/src/GeniusYield/ReadJSON.hs index 52642a45..7b649b97 100644 --- a/src/GeniusYield/ReadJSON.hs +++ b/src/GeniusYield/ReadJSON.hs @@ -13,7 +13,7 @@ import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS import GeniusYield.Imports -readJSON :: (FromJSON a) => FilePath -> IO a +readJSON :: FromJSON a => FilePath -> IO a readJSON fp = do bs <- LBS.readFile fp case Aeson.eitherDecode' bs of diff --git a/src/GeniusYield/Swagger/Utils.hs b/src/GeniusYield/Swagger/Utils.hs index de499228..2d4a269f 100644 --- a/src/GeniusYield/Swagger/Utils.hs +++ b/src/GeniusYield/Swagger/Utils.hs @@ -29,5 +29,5 @@ addSwaggerExample :: (Functor f1, Functor f2, Swagger.HasSchema b1 a, Swagger.Ha addSwaggerExample ex = mapped . mapped . Swagger.schema . Swagger.example ?~ ex -- | Drop the applied type symbol and convert camel case to snake case. -dropSymbolAndCamelToSnake :: forall a. (KnownSymbol a) => String -> String +dropSymbolAndCamelToSnake :: forall a. KnownSymbol a => String -> String dropSymbolAndCamelToSnake = camelTo2 '_' . drop (length $ symbolVal (Proxy @a)) diff --git a/src/GeniusYield/Test/Clb.hs b/src/GeniusYield/Test/Clb.hs index 42a6e798..9aad3cec 100644 --- a/src/GeniusYield/Test/Clb.hs +++ b/src/GeniusYield/Test/Clb.hs @@ -126,7 +126,7 @@ newtype GYTxMonadClb a = GYTxMonadClb { unGYTxMonadClb :: ReaderT GYTxClbEnv (StateT GYTxClbState (ExceptT GYTxMonadException (RandT StdGen AtlasClb))) a } deriving newtype (Functor, Applicative, Monad, MonadReader GYTxClbEnv, MonadState GYTxClbState) - deriving anyclass (GYTxBuilderMonad) + deriving anyclass GYTxBuilderMonad instance MonadRandom GYTxMonadClb where getRandomR = GYTxMonadClb . getRandomR @@ -165,49 +165,49 @@ mkTestFor name action = testNoErrorsTraceClb v w Clb.defaultConway name $ do asClb pureGen (w1 testWallets) nextWalletInt $ action TestInfo {testGoldAsset = fakeCoin fakeGold, testIronAsset = fakeCoin fakeIron, testWallets} - where - -- TODO (simplify-genesis): Remove generation of non ada funds. - v = - valueFromLovelace 1_000_000_000_000_000 - <> fakeValue fakeGold 1_000_000_000 - <> fakeValue fakeIron 1_000_000_000 - - w = - valueFromLovelace 1_000_000_000_000 - <> fakeValue fakeGold 1_000_000 - <> fakeValue fakeIron 1_000_000 - - -- TODO (simplify-genesis):: Remove creation of wallets. Only create one (or more) genesis/funder wallet and pass it on. - testWallets :: Wallets - testWallets = - Wallets - (mkSimpleWallet (Clb.intToKeyPair 1)) - (mkSimpleWallet (Clb.intToKeyPair 2)) - (mkSimpleWallet (Clb.intToKeyPair 3)) - (mkSimpleWallet (Clb.intToKeyPair 4)) - (mkSimpleWallet (Clb.intToKeyPair 5)) - (mkSimpleWallet (Clb.intToKeyPair 6)) - (mkSimpleWallet (Clb.intToKeyPair 7)) - (mkSimpleWallet (Clb.intToKeyPair 8)) - (mkSimpleWallet (Clb.intToKeyPair 9)) - - -- This is the next consecutive number after the highest one used above for 'Clb.intToKeyPair' calls. - nextWalletInt :: Integer - nextWalletInt = 10 - - -- \| Helper for building tests - testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig ApiEra -> String -> AtlasClb a -> Tasty.TestTree - testNoErrorsTraceClb funds walletFunds cfg msg act = - testCaseInfo msg $ - maybe (pure mockLog) assertFailure $ - mbErrors >>= \errors -> pure (mockLog <> "\n\nError :\n-------\n" <> errors) - where - -- _errors since we decided to store errors in the log as well. - (mbErrors, mock) = Clb.runClb (act >> Clb.checkErrors) $ Clb.initClb cfg (valueToApi funds) (valueToApi walletFunds) - mockLog = "\nEmulator log :\n--------------\n" <> logString - options = defaultLayoutOptions {layoutPageWidth = AvailablePerLine 150 1.0} - logDoc = Clb.ppLog $ Clb.mockInfo mock - logString = renderString $ layoutPretty options logDoc + where + -- TODO (simplify-genesis): Remove generation of non ada funds. + v = + valueFromLovelace 1_000_000_000_000_000 + <> fakeValue fakeGold 1_000_000_000 + <> fakeValue fakeIron 1_000_000_000 + + w = + valueFromLovelace 1_000_000_000_000 + <> fakeValue fakeGold 1_000_000 + <> fakeValue fakeIron 1_000_000 + + -- TODO (simplify-genesis):: Remove creation of wallets. Only create one (or more) genesis/funder wallet and pass it on. + testWallets :: Wallets + testWallets = + Wallets + (mkSimpleWallet (Clb.intToKeyPair 1)) + (mkSimpleWallet (Clb.intToKeyPair 2)) + (mkSimpleWallet (Clb.intToKeyPair 3)) + (mkSimpleWallet (Clb.intToKeyPair 4)) + (mkSimpleWallet (Clb.intToKeyPair 5)) + (mkSimpleWallet (Clb.intToKeyPair 6)) + (mkSimpleWallet (Clb.intToKeyPair 7)) + (mkSimpleWallet (Clb.intToKeyPair 8)) + (mkSimpleWallet (Clb.intToKeyPair 9)) + + -- This is the next consecutive number after the highest one used above for 'Clb.intToKeyPair' calls. + nextWalletInt :: Integer + nextWalletInt = 10 + + -- \| Helper for building tests + testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig ApiEra -> String -> AtlasClb a -> Tasty.TestTree + testNoErrorsTraceClb funds walletFunds cfg msg act = + testCaseInfo msg $ + maybe (pure mockLog) assertFailure $ + mbErrors >>= \errors -> pure (mockLog <> "\n\nError :\n-------\n" <> errors) + where + -- _errors since we decided to store errors in the log as well. + (mbErrors, mock) = Clb.runClb (act >> Clb.checkErrors) $ Clb.initClb cfg (valueToApi funds) (valueToApi walletFunds) + mockLog = "\nEmulator log :\n--------------\n" <> logString + options = defaultLayoutOptions {layoutPageWidth = AvailablePerLine 150 1.0} + logDoc = Clb.ppLog $ Clb.mockInfo mock + logString = renderString $ layoutPretty options logDoc mkSimpleWallet :: TL.KeyPair r L.StandardCrypto -> User mkSimpleWallet kp = @@ -248,10 +248,10 @@ mustFailWith isExpectedError act = do } Left err -> liftClb $ logError $ "Action failed with unexpected exception: " ++ show err Right _ -> liftClb $ logError "Expected action to fail but it succeeds" - where - mkMustFailLog (unLog -> pre) (unLog -> post) = - Log $ second (LogEntry Error . ((msg <> ":") <>) . show) <$> Seq.drop (Seq.length pre) post - msg = "Unnamed failure action" + where + mkMustFailLog (unLog -> pre) (unLog -> post) = + Log $ second (LogEntry Error . ((msg <> ":") <>) . show) <$> Seq.drop (Seq.length pre) post + msg = "Unnamed failure action" instance MonadError GYTxMonadException GYTxMonadClb where throwError = GYTxMonadClb . throwError @@ -285,12 +285,12 @@ instance GYTxQueryMonad GYTxMonadClb where Nothing -> utxos Just ac -> filter (\GYUTxO {..} -> valueAssetClass utxoValue ac > 0) utxos return $ utxosFromList utxos' - where - f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) - f ref = do - case txOutRefFromPlutus ref of - Left _ -> return Nothing -- TODO: should it error? - Right ref' -> utxoAtTxOutRef ref' + where + f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) + f ref = do + case txOutRefFromPlutus ref of + Left _ -> return Nothing -- TODO: should it error? + Right ref' -> utxoAtTxOutRef ref' utxosAtPaymentCredential :: GYPaymentCredential -> Maybe GYAssetClass -> GYTxMonadClb GYUTxOs utxosAtPaymentCredential cred mAssetClass = do @@ -301,11 +301,11 @@ instance GYTxQueryMonad GYTxMonadClb where $ filter (\GYUTxO {utxoValue} -> maybe True ((> 0) . valueAssetClass utxoValue) mAssetClass) utxos - where - f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) - f ref = case txOutRefFromPlutus ref of - Left _ -> return Nothing - Right ref' -> utxoAtTxOutRef ref' + where + f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) + f ref = case txOutRefFromPlutus ref of + Left _ -> return Nothing + Right ref' -> utxoAtTxOutRef ref' utxoAtTxOutRef ref = do -- All UTxOs map @@ -399,11 +399,11 @@ instance GYTxUserQueryMonad GYTxMonadClb where case find utxoTranslatableToV1 $ utxosToList utxos of Just u -> return $ utxoRef u Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Better error message here? - where - ifNotV1 utxos addrs = - case someTxOutRef utxos of - Nothing -> throwError $ GYQueryUTxOException $ GYNoUtxosAtAddress addrs - Just (ref, _) -> return ref + where + ifNotV1 utxos addrs = + case someTxOutRef utxos of + Nothing -> throwError $ GYQueryUTxOException $ GYNoUtxosAtAddress addrs + Just (ref, _) -> return ref instance GYTxMonad GYTxMonadClb where signTxBody = signTxBodyImpl . asks $ userPaymentSKey . clbEnvWallet @@ -416,38 +416,38 @@ instance GYTxMonad GYTxMonadClb where case vRes of Success _state _onChainTx -> pure $ txBodyTxId txBody Fail _ err -> throwAppError . someBackendError . T.pack $ show err - where - -- TODO: use Prettyprinter - dumpBody :: GYTxBody -> GYTxMonadClb () - dumpBody body = do - ins <- mapM utxoAtTxOutRef' $ txBodyTxIns body - refIns <- mapM utxoAtTxOutRef' $ txBodyTxInsReference body - gyLogDebug' "" $ - printf - "fee: %d lovelace\nmint value: %s\nvalidity range: %s\ncollateral: %s\ntotal collateral: %d\ninputs:\n\n%sreference inputs:\n\n%soutputs:\n\n%s" - (txBodyFee body) - (txBodyMintValue body) - (show $ txBodyValidityRange body) - (show $ txBodyCollateral body) - (txBodyTotalCollateralLovelace body) - (concatMap dumpInUTxO ins) - (concatMap dumpInUTxO refIns) - (concatMap dumpOutUTxO $ utxosToList $ txBodyUTxOs body) - - dumpInUTxO :: GYUTxO -> String - dumpInUTxO GYUTxO {..} = - printf " - ref: %s\n" utxoRef - <> printf " addr: %s\n" utxoAddress - <> printf " value: %s\n" utxoValue - <> printf " datum: %s\n" (show utxoOutDatum) - <> printf " ref script: %s\n\n" (show utxoRefScript) - - dumpOutUTxO :: GYUTxO -> String - dumpOutUTxO GYUTxO {..} = - printf " - addr: %s\n" utxoAddress - <> printf " value: %s\n" utxoValue - <> printf " datum: %s\n" (show utxoOutDatum) - <> printf " ref script: %s\n\n" (show utxoRefScript) + where + -- TODO: use Prettyprinter + dumpBody :: GYTxBody -> GYTxMonadClb () + dumpBody body = do + ins <- mapM utxoAtTxOutRef' $ txBodyTxIns body + refIns <- mapM utxoAtTxOutRef' $ txBodyTxInsReference body + gyLogDebug' "" $ + printf + "fee: %d lovelace\nmint value: %s\nvalidity range: %s\ncollateral: %s\ntotal collateral: %d\ninputs:\n\n%sreference inputs:\n\n%soutputs:\n\n%s" + (txBodyFee body) + (txBodyMintValue body) + (show $ txBodyValidityRange body) + (show $ txBodyCollateral body) + (txBodyTotalCollateralLovelace body) + (concatMap dumpInUTxO ins) + (concatMap dumpInUTxO refIns) + (concatMap dumpOutUTxO $ utxosToList $ txBodyUTxOs body) + + dumpInUTxO :: GYUTxO -> String + dumpInUTxO GYUTxO {..} = + printf " - ref: %s\n" utxoRef + <> printf " addr: %s\n" utxoAddress + <> printf " value: %s\n" utxoValue + <> printf " datum: %s\n" (show utxoOutDatum) + <> printf " ref script: %s\n\n" (show utxoRefScript) + + dumpOutUTxO :: GYUTxO -> String + dumpOutUTxO GYUTxO {..} = + printf " - addr: %s\n" utxoAddress + <> printf " value: %s\n" utxoValue + <> printf " datum: %s\n" (show utxoOutDatum) + <> printf " ref script: %s\n\n" (show utxoRefScript) -- Transaction submission and confirmation is immediate in CLB. awaitTxConfirmed' _ _ = pure () @@ -501,62 +501,62 @@ instance GYTxSpecialQueryMonad GYTxMonadClb where eraHistory = do (_, len) <- slotConfig' return $ Api.EraHistory $ eh len - where - eh :: NominalDiffTime -> Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) - eh = - Ouroboros.mkInterpreter - . Ouroboros.Summary - . NonEmptyCons byronEra - . NonEmptyCons shelleyEra - . NonEmptyCons allegraEra - . NonEmptyCons maryEra - . NonEmptyCons alonzoEra - . NonEmptyCons babbageEra - . NonEmptyOne - . conwayEra - - byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} - } - shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - conwayEra len = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength len, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } + where + eh :: NominalDiffTime -> Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) + eh = + Ouroboros.mkInterpreter + . Ouroboros.Summary + . NonEmptyCons byronEra + . NonEmptyCons shelleyEra + . NonEmptyCons allegraEra + . NonEmptyCons maryEra + . NonEmptyCons alonzoEra + . NonEmptyCons babbageEra + . NonEmptyOne + . conwayEra + + byronEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} + } + shelleyEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + allegraEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + maryEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + alonzoEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + babbageEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + conwayEra len = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength len, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } dumpUtxoState :: GYTxMonadClb () dumpUtxoState = liftClb Clb.dumpUtxoState @@ -569,12 +569,12 @@ pureGen :: StdGen pureGen = mkStdGen 42 -- | This is simply defined as @buildTxBody skeleton >>= signAndSubmitConfirmed@. -sendSkeleton :: (GYTxMonad m) => GYTxSkeleton v -> m GYTxId +sendSkeleton :: GYTxMonad m => GYTxSkeleton v -> m GYTxId sendSkeleton skeleton = snd <$> sendSkeleton' skeleton -sendSkeleton' :: (GYTxMonad m) => GYTxSkeleton v -> m (GYTxBody, GYTxId) +sendSkeleton' :: GYTxMonad m => GYTxSkeleton v -> m (GYTxBody, GYTxId) sendSkeleton' skeleton = buildTxBody skeleton >>= \tx -> signAndSubmitConfirmed tx >>= \txId -> pure (tx, txId) -- | Variant of `logInfo` from @Clb@ that logs a string with @Info@ severity. -logInfoS :: (Monad m) => String -> ClbT ApiEra m () +logInfoS :: Monad m => String -> ClbT ApiEra m () logInfoS s = Clb.logInfo $ Clb.LogEntry Clb.Info s diff --git a/src/GeniusYield/Test/FeeTracker.hs b/src/GeniusYield/Test/FeeTracker.hs index c5a76de5..931cda49 100644 --- a/src/GeniusYield/Test/FeeTracker.hs +++ b/src/GeniusYield/Test/FeeTracker.hs @@ -90,14 +90,14 @@ newtype FeeTracker m a = FeeTracker (FeeTrackerState -> m (a, FeeTrackerState)) deriving via StateT FeeTrackerState m instance - (MonadError GYTxMonadException m) => MonadError GYTxMonadException (FeeTracker m) + MonadError GYTxMonadException m => MonadError GYTxMonadException (FeeTracker m) -- | Perform a special action supported by the specific wrapped monad instance by lifting it to 'FeeTracker'. -ftLift :: (Functor m) => m a -> FeeTracker m a +ftLift :: Functor m => m a -> FeeTracker m a ftLift act = FeeTracker $ \s -> (,s) <$> act -- | Override given transaction building function to track extra lovelace per transaction. -wrapBodyBuilder :: (GYTxUserQueryMonad m) => ([GYTxSkeleton v] -> m GYTxBuildResult) -> [GYTxSkeleton v] -> FeeTracker m GYTxBuildResult +wrapBodyBuilder :: GYTxUserQueryMonad m => ([GYTxSkeleton v] -> m GYTxBuildResult) -> [GYTxSkeleton v] -> FeeTracker m GYTxBuildResult wrapBodyBuilder f skeletons = do ownPkh <- ownChangeAddress >>= addressToPubKeyHash' res <- ftLift $ f skeletons @@ -107,29 +107,29 @@ wrapBodyBuilder f skeletons = do GYTxBuildPartialSuccess _ txBodies -> helpers txBodies _ -> pure () pure res - where - helper ownPkh (skeleton, txBody) = do - -- Actual outputs with their blueprints (counterpart from skeleton) - -- NOTE: This relies on proper ordering. 'txBodyUTxOs txBody' is expected to have the same order - -- as the outputs in the skeleton. The extra balancing outputs at the end of the list of 'txBodyUTxOs txBody' - -- should be truncated by 'zip'. - let outsWithBlueprint = zip (gytxOuts skeleton) . utxosToList $ txBodyUTxOs txBody - feeExtraLovelace = stSingleton ownPkh mempty {uelFees = Sum $ txBodyFee txBody} - depositsExtraLovelace = - foldMap' - ( \(blueprint, actual) -> - let targetAddr = gyTxOutAddress blueprint - deposit = Sum . flip valueAssetClass GYLovelace $ utxoValue actual `valueMinus` gyTxOutValue blueprint - -- These two will cancel out if the ada is going to own address. - ownLostDeposit = stSingleton ownPkh mempty {uelMinAda = deposit} - otherGainedDeposit = maybe mempty (`stSingleton` mempty {uelMinAda = negate deposit}) $ addressToPubKeyHash targetAddr - in ownLostDeposit <> otherGainedDeposit - ) - outsWithBlueprint - modify' (\prev -> prev <> feeExtraLovelace <> depositsExtraLovelace) + where + helper ownPkh (skeleton, txBody) = do + -- Actual outputs with their blueprints (counterpart from skeleton) + -- NOTE: This relies on proper ordering. 'txBodyUTxOs txBody' is expected to have the same order + -- as the outputs in the skeleton. The extra balancing outputs at the end of the list of 'txBodyUTxOs txBody' + -- should be truncated by 'zip'. + let outsWithBlueprint = zip (gytxOuts skeleton) . utxosToList $ txBodyUTxOs txBody + feeExtraLovelace = stSingleton ownPkh mempty {uelFees = Sum $ txBodyFee txBody} + depositsExtraLovelace = + foldMap' + ( \(blueprint, actual) -> + let targetAddr = gyTxOutAddress blueprint + deposit = Sum . flip valueAssetClass GYLovelace $ utxoValue actual `valueMinus` gyTxOutValue blueprint + -- These two will cancel out if the ada is going to own address. + ownLostDeposit = stSingleton ownPkh mempty {uelMinAda = deposit} + otherGainedDeposit = maybe mempty (`stSingleton` mempty {uelMinAda = negate deposit}) $ addressToPubKeyHash targetAddr + in ownLostDeposit <> otherGainedDeposit + ) + outsWithBlueprint + modify' (\prev -> prev <> feeExtraLovelace <> depositsExtraLovelace) -- | Override transaction building code of the inner monad to track extra lovelace per transaction. -instance (GYTxBuilderMonad m) => GYTxBuilderMonad (FeeTracker m) where +instance GYTxBuilderMonad m => GYTxBuilderMonad (FeeTracker m) where type TxBuilderStrategy (FeeTracker m) = TxBuilderStrategy m buildTxBodyWithStrategy strat skeleton = do res <- wrapBodyBuilder (\x -> GYTxBuildSuccess . NE.singleton <$> buildTxBodyWithStrategy @m strat (head x)) [skeleton] @@ -143,7 +143,7 @@ instance (GYTxBuilderMonad m) => GYTxBuilderMonad (FeeTracker m) where Useful for building a tx body without the intent to submit it later. Thereby ignoring all the tracked fees from that txbody that won't actually take effect in the wallet (since it won't be submitted). -} -withoutFeeTracking :: (Monad m) => FeeTracker m a -> FeeTracker m a +withoutFeeTracking :: Monad m => FeeTracker m a -> FeeTracker m a withoutFeeTracking act = do s <- get a <- act @@ -168,16 +168,16 @@ newtype FeeTrackerGame m a = FeeTrackerGame (FeeTrackerState -> m (a, FeeTracker deriving via StateT FeeTrackerState m instance - (MonadError GYTxMonadException m) => MonadError GYTxMonadException (FeeTrackerGame m) + MonadError GYTxMonadException m => MonadError GYTxMonadException (FeeTrackerGame m) -evalFtg :: (Functor f) => FeeTrackerGame f b -> f b +evalFtg :: Functor f => FeeTrackerGame f b -> f b evalFtg (FeeTrackerGame act) = fst <$> act mempty -- | Perform a special action supported by the specific wrapped monad instance by lifting it to 'FeeTrackerGame'. -ftgLift :: (Functor m) => m a -> FeeTrackerGame m a +ftgLift :: Functor m => m a -> FeeTrackerGame m a ftgLift act = FeeTrackerGame $ \s -> (,s) <$> act -instance (GYTxGameMonad m) => GYTxGameMonad (FeeTrackerGame m) where +instance GYTxGameMonad m => GYTxGameMonad (FeeTrackerGame m) where type TxMonadOf (FeeTrackerGame m) = FeeTracker (TxMonadOf m) createUser = ftgLift createUser asUser u (FeeTracker act) = FeeTrackerGame $ asUser u . act @@ -212,11 +212,11 @@ Notes: * An empty list means no checks are performed. * The 'GYValue' should be negative to check if the Wallet lost those funds. -} -withWalletBalancesCheckSimple :: (GYTxGameMonad m) => [(User, GYValue)] -> FeeTrackerGame m a -> m a +withWalletBalancesCheckSimple :: GYTxGameMonad m => [(User, GYValue)] -> FeeTrackerGame m a -> m a withWalletBalancesCheckSimple wallValueDiffs = withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs mempty -- | Variant of `withWalletBalancesCheckSimple` that only accounts for transaction fees and not minimum ada deposits. -withWalletBalancesCheckSimpleIgnoreMinDepFor :: (GYTxGameMonad m) => [(User, GYValue)] -> Set User -> FeeTrackerGame m a -> m a +withWalletBalancesCheckSimpleIgnoreMinDepFor :: GYTxGameMonad m => [(User, GYValue)] -> Set User -> FeeTrackerGame m a -> m a withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs ignoreMinDepFor m = evalFtg $ do bs <- mapM (queryBalances . userAddresses' . fst) wallValueDiffs a <- m @@ -246,6 +246,6 @@ withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs ignoreMinDepFor m = (encodeJsonText v) (encodeJsonText diff) pure a - where - encodeJsonText :: (ToJSON a) => a -> Text - encodeJsonText = LT.toStrict . LTE.decodeUtf8 . Aeson.encode + where + encodeJsonText :: ToJSON a => a -> Text + encodeJsonText = LT.toStrict . LTE.decodeUtf8 . Aeson.encode diff --git a/src/GeniusYield/Test/Privnet/Asserts.hs b/src/GeniusYield/Test/Privnet/Asserts.hs index 83bb99a6..c7304e83 100644 --- a/src/GeniusYield/Test/Privnet/Asserts.hs +++ b/src/GeniusYield/Test/Privnet/Asserts.hs @@ -26,13 +26,13 @@ import GeniusYield.Types import GeniusYield.Test.Privnet.Ctx -assertFee :: (HasCallStack) => GYTxBody -> Integer -> Integer -> IO () +assertFee :: HasCallStack => GYTxBody -> Integer -> Integer -> IO () assertFee (txBodyFee -> fee) lb ub | fee < lb = assertFailure $ printf "Fee: %d less than %d" fee lb | fee > ub = assertFailure $ printf "Fee: %d greater than %d" fee ub | otherwise = return () -assertThrown :: forall e a. (Exception e) => (e -> Bool) -> IO a -> IO () +assertThrown :: forall e a. Exception e => (e -> Bool) -> IO a -> IO () assertThrown p action = do thrownRef <- newIORef False void action `catch` \e -> @@ -42,8 +42,8 @@ assertThrown p action = do thrown <- readIORef thrownRef unless thrown $ assertFailure $ "Expecting an exception: " ++ name - where - name = show (typeRep (Proxy @e)) + where + name = show (typeRep (Proxy @e)) -- | Asserts if the user funds change as expected. This function subtracts fees from the given expected value. assertUserFunds :: Integer -> Ctx -> User -> GYValue -> IO () diff --git a/src/GeniusYield/Test/Privnet/Examples/Gift.hs b/src/GeniusYield/Test/Privnet/Examples/Gift.hs index 731a589b..369169c0 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Gift.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Gift.hs @@ -496,7 +496,7 @@ tests setup = -- TODO: NonOutputSupplimentaryDatums is thrown by other tests when this test is run. -- They fail to consume utxos with (inline) datums. -- We need to fix utxosDatums to also return whether the datum was inline. - let addNewGiftV2 :: (GYTxUserQueryMonad m) => GYTxSkeleton 'PlutusV2 -> m (GYTxSkeleton 'PlutusV2) + let addNewGiftV2 :: GYTxUserQueryMonad m => GYTxSkeleton 'PlutusV2 -> m (GYTxSkeleton 'PlutusV2) addNewGiftV2 skeleton = do addr <- scriptAddress giftValidatorV2 return $ @@ -620,7 +620,7 @@ grabGifts validator = do -- | Grab gifts using a referenced validator. grabGiftsRef :: - (GYTxQueryMonad m) => + GYTxQueryMonad m => GYTxOutRef -> GYValidator 'PlutusV2 -> m (Maybe (GYTxSkeleton 'PlutusV2)) @@ -649,7 +649,7 @@ grabGiftsRef ref validator = do -- | Function to check for consistency of collaterals with respect to ledger laws. checkCollateral :: - (Integral a) => + Integral a => -- | Sum of values present in collateral inputs. GYValue -> -- | Value present in return collateral output. @@ -667,5 +667,5 @@ checkCollateral inputValue returnValue totalCollateralLovelace txFee collPer = && totalCollateralLovelace == balanceLovelace && balanceLovelace >= ceiling (txFee * collPer % 100) -- Api checks via `balanceLovelace * 100 >= txFee * collPer` which IMO works as `balanceLovelace` is an integer & 100 but in general `c >= ceil (a / b)` is not equivalent to `c * b >= a`. && inputValue == returnValue <> valueFromLovelace totalCollateralLovelace - where - (balanceLovelace, balanceOther) = valueSplitAda $ inputValue `valueMinus` returnValue + where + (balanceLovelace, balanceOther) = valueSplitAda $ inputValue `valueMinus` returnValue diff --git a/src/GeniusYield/Test/Privnet/Setup.hs b/src/GeniusYield/Test/Privnet/Setup.hs index ac5cc8e9..2b564e7e 100644 --- a/src/GeniusYield/Test/Privnet/Setup.hs +++ b/src/GeniusYield/Test/Privnet/Setup.hs @@ -353,13 +353,13 @@ withPrivnet testnetOpts setupUser = do let setup = Setup $ \targetSev putLog kont -> kont $ ctx {ctxLog = simpleLogging targetSev (putLog . Txt.unpack)} setupUser setup - where - -- \| This is defined same as `cardanoTestnetDefault` except we use our own conway genesis parameters. - cardanoTestnet' opts conf = do - Api.AnyCardanoEra cEra <- pure $ cardanoNodeEra cardanoDefaultTestnetOptions - alonzoGenesis <- getDefaultAlonzoGenesis cEra - (startTime, shelleyGenesis') <- getDefaultShelleyGenesis opts - cardanoTestnet opts conf startTime shelleyGenesis' alonzoGenesis conwayGenesis + where + -- \| This is defined same as `cardanoTestnetDefault` except we use our own conway genesis parameters. + cardanoTestnet' opts conf = do + Api.AnyCardanoEra cEra <- pure $ cardanoNodeEra cardanoDefaultTestnetOptions + alonzoGenesis <- getDefaultAlonzoGenesis cEra + (startTime, shelleyGenesis') <- getDefaultShelleyGenesis opts + cardanoTestnet opts conf startTime shelleyGenesis' alonzoGenesis conwayGenesis ------------------------------------------------------------------------------- -- Generating users @@ -387,8 +387,8 @@ generateUser network = do ) pure User' {userPaymentSKey' = paymentSigningKeyFromApi skey, userAddr = addr, userStakeSKey' = Nothing} - where - stake = Api.NoStakeAddress + where + stake = Api.NoStakeAddress ------------------------------------------------------------------------------- -- Balance @@ -425,6 +425,6 @@ mintTestTokens ctx tn' = do (ac, txBody) <- GY.TestTokens.mintTestTokens tn 1_000_000_000 >>= traverse buildTxBody signAndSubmitConfirmed_ txBody pure ac - where - tn :: GYTokenName - tn = fromString tn' + where + tn :: GYTokenName + tn = fromString tn' diff --git a/src/GeniusYield/Test/Privnet/Utils.hs b/src/GeniusYield/Test/Privnet/Utils.hs index 8baeadf0..ccc59ef2 100644 --- a/src/GeniusYield/Test/Privnet/Utils.hs +++ b/src/GeniusYield/Test/Privnet/Utils.hs @@ -38,5 +38,5 @@ urlPieceFromText t = case Web.parseUrlPiece t of printf "Failed to parse %s from %s: %s\n" (show (typeRep @a)) t msg exitFailure -urlPieceToFile :: forall a. (Web.ToHttpApiData a) => FilePath -> a -> IO () +urlPieceToFile :: forall a. Web.ToHttpApiData a => FilePath -> a -> IO () urlPieceToFile p x = T.IO.writeFile p (Web.toUrlPiece x) diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index 1ad18f42..afb81f2c 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -58,15 +58,15 @@ import GeniusYield.Test.FeeTracker as X -- | Runs the second 'Tasty.TestTree' after all tests in the first 'Tasty.TestTree' succeed afterAllSucceed :: Tasty.TestTree -> Tasty.TestTree -> Tasty.TestTree afterAllSucceed = Tasty.after Tasty.AllSucceed . pat - where - pat :: Tasty.TestTree -> String - pat dep = case dep of - Tasty.SingleTest tn _ -> tn - Tasty.TestGroup tn _ -> tn - Tasty.After _ _ dep' -> pat dep' - Tasty.PlusTestOptions _ dep' -> pat dep' - Tasty.WithResource _ f -> pat (f (fail "Not running IO")) - Tasty.AskOptions f -> pat (f mempty) + where + pat :: Tasty.TestTree -> String + pat dep = case dep of + Tasty.SingleTest tn _ -> tn + Tasty.TestGroup tn _ -> tn + Tasty.After _ _ dep' -> pat dep' + Tasty.PlusTestOptions _ dep' -> pat dep' + Tasty.WithResource _ f -> pat (f (fail "Not running IO")) + Tasty.AskOptions f -> pat (f mempty) ------------------------------------------------------------------------------- -- QC @@ -75,9 +75,9 @@ afterAllSucceed = Tasty.after Tasty.AllSucceed . pat -- | Adjust the number of QuickCheck cases to generate. withMaxQCTests :: Int -> Tasty.TestTree -> Tasty.TestTree withMaxQCTests n = Tasty.adjustOption f - where - f :: Tasty.QuickCheckTests -> Tasty.QuickCheckTests - f (Tasty.QuickCheckTests m) = Tasty.QuickCheckTests (min m n) + where + f :: Tasty.QuickCheckTests -> Tasty.QuickCheckTests + f (Tasty.QuickCheckTests m) = Tasty.QuickCheckTests (min m n) ------------------------------------------------------------------------------- -- test assets @@ -132,7 +132,7 @@ data Wallets = Wallets deriving (Show, Eq, Ord) -- | Create an user and fund them with the given amount of lovelace provided by the given funder user. -createUserWithLovelace :: (GYTxGameMonad m) => User -> Natural -> m User +createUserWithLovelace :: GYTxGameMonad m => User -> Natural -> m User createUserWithLovelace funder lovelace = do u <- createUser asUser funder $ do @@ -166,14 +166,14 @@ createUserWithLovelace funder lovelace = do Note: This will obviously require the user to have enough lovelace to cover the fees and min ada deposits for the mints. -} -createUserWithAssets :: (GYTxGameMonad m) => User -> Natural -> [(FakeCoin, Natural)] -> m User +createUserWithAssets :: GYTxGameMonad m => User -> Natural -> [(FakeCoin, Natural)] -> m User createUserWithAssets funder lovelace tokens = do user <- createUserWithLovelace funder lovelace asUser user $ mintTestAssets tokens pure user -- | Create a collateral utxo out of the existing ada within a user wallet. Returns the collateral reference. -generateCollateral :: (GYTxMonad m) => m GYTxOutRef +generateCollateral :: GYTxMonad m => m GYTxOutRef generateCollateral = do addr <- ownChangeAddress gyLogDebug' "mintTestAssets" . T.unpack $ @@ -190,14 +190,14 @@ generateCollateral = do It creates a user with ada, non-ada assets, and a collateral. Thereby making a user ready to participate in smart contracts. -} -createUserFull :: (GYTxGameMonad m) => User -> Natural -> [(FakeCoin, Natural)] -> m User +createUserFull :: GYTxGameMonad m => User -> Natural -> [(FakeCoin, Natural)] -> m User createUserFull funder lovelace tokens = do user <- createUserWithAssets funder lovelace tokens userCollateralRef <- asUser user generateCollateral pure user {userCollateral = Just UserCollateral {userCollateralRef, userCollateralCheck = True}} -- | Mint given amount of test tokens. -mintTestAssets :: (GYTxMonad m) => [(FakeCoin, Natural)] -> m () +mintTestAssets :: GYTxMonad m => [(FakeCoin, Natural)] -> m () mintTestAssets tokens = do addr <- ownChangeAddress let readableTkNames = @@ -218,13 +218,13 @@ mintTestAssets tokens = do ) tokens signAndSubmitConfirmed_ txBody - where - readableTk tk = mintingPolicyIdToText (mintingPolicyId $ fakePolicy tk) <> "." <> T.pack (show $ fakeCoinName tk) + where + readableTk tk = mintingPolicyIdToText (mintingPolicyId $ fakePolicy tk) <> "." <> T.pack (show $ fakeCoinName tk) {- | Computes a `GYTx*Monad` action and returns the result and how this action changed the balance of some "Address". -} -withBalance :: (GYTxQueryMonad m) => String -> User -> m b -> m (b, GYValue) +withBalance :: GYTxQueryMonad m => String -> User -> m b -> m (b, GYValue) withBalance n a m = do old <- queryBalance $ userAddr a b <- m @@ -239,7 +239,7 @@ Notes: * An empty list means no checks are performed. * The 'GYValue' should be negative to check if the Wallet lost those funds. -} -withWalletBalancesCheck :: (GYTxQueryMonad m) => [(User, GYValue)] -> m a -> m a +withWalletBalancesCheck :: GYTxQueryMonad m => [(User, GYValue)] -> m a -> m a withWalletBalancesCheck [] m = m withWalletBalancesCheck ((w, v) : xs) m = do (b, diff) <- withBalance (show $ userAddr w) w $ withWalletBalancesCheck xs m @@ -251,7 +251,7 @@ withWalletBalancesCheck ((w, v) : xs) m = do Returns Nothing if it fails to decode an address contained in the transaction outputs. -} -findLockedUtxosInBody :: (Num a) => GYAddress -> GYTx -> Maybe [a] +findLockedUtxosInBody :: Num a => GYAddress -> GYTx -> Maybe [a] findLockedUtxosInBody addr tx = let os = utxosToList . txBodyUTxOs $ getTxBody tx @@ -264,7 +264,7 @@ findLockedUtxosInBody addr tx = findAllMatches (0, os, []) -- | Find reference scripts at given address. -getRefInfos :: (GYTxQueryMonad m) => GYAddress -> m (Map GYAnyScript GYTxOutRef) +getRefInfos :: GYTxQueryMonad m => GYAddress -> m (Map GYAnyScript GYTxOutRef) getRefInfos addr = do utxo <- utxosAtAddress addr Nothing return $ utxoToRefMap utxo @@ -285,7 +285,7 @@ findRefScriptsInBody body = do {- | Adds the given script to the given address and returns the reference for it. Note: The new utxo is given an inline unit datum. -} -addRefScript :: forall m. (GYTxMonad m) => GYAddress -> GYScript 'PlutusV2 -> m GYTxOutRef +addRefScript :: forall m. GYTxMonad m => GYAddress -> GYScript 'PlutusV2 -> m GYTxOutRef addRefScript addr sc = throwAppError absurdError `runEagerT` do existingUtxos <- lift $ utxosAtAddress addr Nothing @@ -303,12 +303,12 @@ addRefScript addr sc = } lift $ signAndSubmitConfirmed_ txBody maybeToEager . Map.lookup (GYPlutusScript sc) $ findRefScriptsInBody txBody - where - absurdError = someBackendError "Shouldn't happen: no ref in body" + where + absurdError = someBackendError "Shouldn't happen: no ref in body" -- | Adds an input (whose datum we'll refer later) and returns the reference to it. addRefInput :: - (GYTxMonad m) => + GYTxMonad m => -- | Whether to inline this datum? Bool -> -- | Where to place this output? @@ -328,19 +328,19 @@ addRefInput toInline addr dat = lift $ signAndSubmitConfirmed_ txBody maybeToEager . findRefWithDatum $ txBodyUTxOs txBody - where - findRefWithDatum :: GYUTxOs -> Maybe GYTxOutRef - findRefWithDatum utxos = - fmap utxoRef - . find - ( \GYUTxO {utxoOutDatum} -> - case utxoOutDatum of - GYOutDatumHash dh -> hashDatum dat == dh - GYOutDatumInline dat' -> dat == dat' - _ -> False - ) - $ utxosToList utxos - absurdError = someBackendError "Shouldn't happen: no output with expected datum in body" + where + findRefWithDatum :: GYUTxOs -> Maybe GYTxOutRef + findRefWithDatum utxos = + fmap utxoRef + . find + ( \GYUTxO {utxoOutDatum} -> + case utxoOutDatum of + GYOutDatumHash dh -> hashDatum dat == dh + GYOutDatumInline dat' -> dat == dat' + _ -> False + ) + $ utxosToList utxos + absurdError = someBackendError "Shouldn't happen: no output with expected datum in body" {- | Abstraction for explicitly building a Value representing the fees of a transaction. @@ -368,11 +368,11 @@ type EagerT m a = ExceptT a m () {- | If we have a 'Just' value, we can exit with it immediately. So it gets converted to 'Left'. -} -maybeToEager :: (Monad m) => Maybe a -> EagerT m a +maybeToEager :: Monad m => Maybe a -> EagerT m a maybeToEager (Just a) = throwError a maybeToEager Nothing = pure () -- If all goes well, we should finish with a 'Left'. if not, we perform the -- given action to signal error. -runEagerT :: (Monad m) => m a -> ExceptT a m () -> m a +runEagerT :: Monad m => m a -> ExceptT a m () -> m a runEagerT whenError = runExceptT >=> either pure (const whenError) diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index 889ac01e..943af365 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -161,76 +161,76 @@ buildUnsignedTxBody :: Maybe GYTxMetadata -> m (Either GYBuildTxError GYTxBody) buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub signers mbTxMetadata = buildTxLoop cstrat extraLovelaceStart - where - certsFinalised = finaliseTxCert (gyBTxEnvProtocolParams env) <$> certs - - step :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError ([GYTxInDetailed v], GYUTxOs, [GYTxOut v])) - step stepStrat = fmap (first GYBuildTxBalancingError) . balanceTxStep env mmint wdrls certsFinalised insOld outsOld stepStrat - - buildTxLoop :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) - buildTxLoop stepStrat n - -- Stop trying with RandomImprove if extra lovelace has hit the pre-determined ceiling. - | stepStrat /= GYLargestFirstMultiAsset && n >= randImproveExtraLovelaceCeil = buildTxLoop GYLargestFirstMultiAsset n - | otherwise = do - res <- f stepStrat n - case res of - {- These errors generally indicate the input selection process selected less ada - than necessary. Try again with double the extra lovelace amount -} - Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceNegative {}) -> buildTxLoop stepStrat (n * 2) - Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceTooSmall {}) -> buildTxLoop stepStrat (n * 2) - -- @RandomImprove@ may result into many change outputs, where their minimum ada requirements might be unsatisfiable with available ada. - Left (GYBuildTxBalancingError err@(GYBalancingErrorChangeShortFall _)) -> - retryIfRandomImprove - stepStrat - n - (GYBuildTxBalancingError err) - {- RandomImprove may end up selecting too many inputs to fit in the transaction. - In this case, try with LargestFirst and dial back the extraLovelace param. - -} - Left (GYBuildTxExUnitsTooBig maxUnits currentUnits) -> - retryIfRandomImprove - stepStrat - n - (GYBuildTxExUnitsTooBig maxUnits currentUnits) - Left (GYBuildTxSizeTooBig maxPossibleSize currentSize) -> - retryIfRandomImprove - stepStrat - n - (GYBuildTxSizeTooBig maxPossibleSize currentSize) - Right x -> pure $ Right x - {- The most common error here would be: - - InsufficientFunds - - Script validation failure - - Tx not within validity range specified timeframe - - No need to try again for these. - -} - other -> pure other - - f :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) - f stepStrat pessimisticFee = do - stepRes <- step stepStrat pessimisticFee - pure $ - stepRes >>= \(ins, collaterals, outs) -> - finalizeGYBalancedTx - env - GYBalancedTx - { gybtxIns = ins - , gybtxCollaterals = collaterals - , gybtxOuts = outs - , gybtxMint = mmint - , gybtxWdrls = wdrls - , gybtxCerts = certsFinalised - , gybtxInvalidBefore = lb - , gybtxInvalidAfter = ub - , gybtxSigners = signers - , gybtxRefIns = refIns - , gybtxMetadata = mbTxMetadata - } - (length outsOld) - - retryIfRandomImprove GYRandomImproveMultiAsset n _ = buildTxLoop GYLargestFirstMultiAsset (if n == extraLovelaceStart then extraLovelaceStart else n `div` 2) - retryIfRandomImprove _ _ err = pure $ Left err + where + certsFinalised = finaliseTxCert (gyBTxEnvProtocolParams env) <$> certs + + step :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError ([GYTxInDetailed v], GYUTxOs, [GYTxOut v])) + step stepStrat = fmap (first GYBuildTxBalancingError) . balanceTxStep env mmint wdrls certsFinalised insOld outsOld stepStrat + + buildTxLoop :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) + buildTxLoop stepStrat n + -- Stop trying with RandomImprove if extra lovelace has hit the pre-determined ceiling. + | stepStrat /= GYLargestFirstMultiAsset && n >= randImproveExtraLovelaceCeil = buildTxLoop GYLargestFirstMultiAsset n + | otherwise = do + res <- f stepStrat n + case res of + {- These errors generally indicate the input selection process selected less ada + than necessary. Try again with double the extra lovelace amount -} + Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceNegative {}) -> buildTxLoop stepStrat (n * 2) + Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceTooSmall {}) -> buildTxLoop stepStrat (n * 2) + -- @RandomImprove@ may result into many change outputs, where their minimum ada requirements might be unsatisfiable with available ada. + Left (GYBuildTxBalancingError err@(GYBalancingErrorChangeShortFall _)) -> + retryIfRandomImprove + stepStrat + n + (GYBuildTxBalancingError err) + {- RandomImprove may end up selecting too many inputs to fit in the transaction. + In this case, try with LargestFirst and dial back the extraLovelace param. + -} + Left (GYBuildTxExUnitsTooBig maxUnits currentUnits) -> + retryIfRandomImprove + stepStrat + n + (GYBuildTxExUnitsTooBig maxUnits currentUnits) + Left (GYBuildTxSizeTooBig maxPossibleSize currentSize) -> + retryIfRandomImprove + stepStrat + n + (GYBuildTxSizeTooBig maxPossibleSize currentSize) + Right x -> pure $ Right x + {- The most common error here would be: + - InsufficientFunds + - Script validation failure + - Tx not within validity range specified timeframe + + No need to try again for these. + -} + other -> pure other + + f :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) + f stepStrat pessimisticFee = do + stepRes <- step stepStrat pessimisticFee + pure $ + stepRes >>= \(ins, collaterals, outs) -> + finalizeGYBalancedTx + env + GYBalancedTx + { gybtxIns = ins + , gybtxCollaterals = collaterals + , gybtxOuts = outs + , gybtxMint = mmint + , gybtxWdrls = wdrls + , gybtxCerts = certsFinalised + , gybtxInvalidBefore = lb + , gybtxInvalidAfter = ub + , gybtxSigners = signers + , gybtxRefIns = refIns + , gybtxMetadata = mbTxMetadata + } + (length outsOld) + + retryIfRandomImprove GYRandomImproveMultiAsset n _ = buildTxLoop GYLargestFirstMultiAsset (if n == extraLovelaceStart then extraLovelaceStart else n `div` 2) + retryIfRandomImprove _ _ err = pure $ Left err ------------------------------------------------------------------------------- -- Primary balancing logic @@ -321,14 +321,14 @@ balanceTxStep } cstrat pure (ins ++ addIns, collaterals, adjustedOuts ++ changeOuts) - where - isScriptWitness GYTxInWitnessKey = False - isScriptWitness GYTxInWitnessScript {} = True - isScriptWitness GYTxInWitnessSimpleScript {} = False -- Simple (native) scripts don't require collateral. - isCertScriptWitness (Just GYTxCertWitnessScript {}) = True - isCertScriptWitness _ = False - isWdrlScriptWitness GYTxWdrlWitnessScript {} = True - isWdrlScriptWitness _ = False + where + isScriptWitness GYTxInWitnessKey = False + isScriptWitness GYTxInWitnessScript {} = True + isScriptWitness GYTxInWitnessSimpleScript {} = False -- Simple (native) scripts don't require collateral. + isCertScriptWitness (Just GYTxCertWitnessScript {}) = True + isCertScriptWitness _ = False + isWdrlScriptWitness GYTxWdrlWitnessScript {} = True + isWdrlScriptWitness _ = False retColSup :: Api.BabbageEraOnwards ApiEra retColSup = Api.BabbageEraOnwardsConway @@ -366,173 +366,173 @@ finalizeGYBalancedTx changeAddr unregisteredStakeCredsMap estimateKeyWitnesses - where - -- Over-estimate the number of key witnesses required for the transaction. - -- We do not provide support for byron key witnesses in our estimate as @Api.makeTransactionBodyAutoBalance@ does not consider them, i.e., count of key witnesses returned here are considered as shelley key witnesses by cardano api. - estimateKeyWitnesses :: Word = - fromIntegral $ - countUnique $ - mapMaybe (extractPaymentPkhFromAddress . utxoAddress) (utxosToList collaterals) - <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxWdrlWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferSCByKey sc]] - <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxCertWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferSCByKey sc]] - <> estimateKeyWitnessesFromInputs ins - <> Set.toList signers - where - extractPaymentPkhFromAddress gyaddr = - addressToPaymentCredential gyaddr >>= \case - GYPaymentCredentialByKey pkh -> Just $ toPubKeyHash pkh - GYPaymentCredentialByScript _ -> Nothing - - preferSCByKey (GYStakeCredentialByKey pkh) = Just $ toPubKeyHash pkh - preferSCByKey _otherwise = Nothing - - countUnique :: (Ord a) => [a] -> Int - countUnique = Set.size . Set.fromList - - estimateKeyWitnessesFromInputs txInDets = - -- Count key witnesses. - [apkh | txInDet@GYTxInDetailed {gyTxInDet = GYTxIn {gyTxInWitness = GYTxInWitnessKey}} <- txInDets, let gyaddr = gyTxInDetAddress txInDet, Just apkh <- [extractPaymentPkhFromAddress gyaddr]] - ++ - -- Estimate key witnesses required by native scripts. - map toPubKeyHash (Set.toList $ foldl' estimateKeyWitnessesFromNativeScripts mempty txInDets) - where - estimateKeyWitnessesFromNativeScripts acc (gyTxInWitness . gyTxInDet -> GYTxInWitnessSimpleScript gyInSS) = - case gyInSS of - GYInSimpleScript s -> getTotalKeysInSimpleScript s <> acc - GYInReferenceSimpleScript _ s -> getTotalKeysInSimpleScript s <> acc - estimateKeyWitnessesFromNativeScripts acc _ = acc - - inRefs :: Api.TxInsReference Api.BuildTx ApiEra - inRefs = case inRefs' of - [] -> Api.TxInsReferenceNone - _ -> Api.TxInsReference Api.BabbageEraOnwardsConway inRefs' - - inRefs' :: [Api.TxIn] - inRefs' = [txOutRefToApi r | r <- utxosRefs utxosRefInputs] - - -- utxos for inputs - utxosIn :: GYUTxOs - utxosIn = utxosFromList $ utxoFromTxInDetailed <$> ins - - -- Map to lookup information for various utxos. - utxos :: GYUTxOs - utxos = utxosIn <> utxosRefInputs <> collaterals - - outs' :: [Api.S.TxOut Api.S.CtxTx ApiEra] - outs' = txOutToApi <$> outs - - ins' :: [(Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn ApiEra))] - ins' = [txInToApi (isInlineDatum $ gyTxInDetDatum i) (gyTxInDet i) | i <- ins] - - collaterals' :: Api.TxInsCollateral ApiEra - collaterals' = case utxosRefs collaterals of - [] -> Api.TxInsCollateralNone - orefs -> Api.TxInsCollateral Api.AlonzoEraOnwardsConway $ txOutRefToApi <$> orefs - - -- will be filled by makeTransactionBodyAutoBalance - fee :: Api.TxFee ApiEra - fee = Api.TxFeeExplicit Api.ShelleyBasedEraConway $ Ledger.Coin 0 - - lb' :: Api.TxValidityLowerBound ApiEra - lb' = - maybe - Api.TxValidityNoLowerBound - (Api.TxValidityLowerBound Api.AllegraEraOnwardsConway . slotToApi) - lb - - ub' :: Api.TxValidityUpperBound ApiEra - ub' = Api.TxValidityUpperBound Api.ShelleyBasedEraConway $ slotToApi <$> ub - - extra :: Api.TxExtraKeyWitnesses ApiEra - extra = case toList signers of - [] -> Api.TxExtraKeyWitnessesNone - pkhs -> Api.TxExtraKeyWitnesses Api.AlonzoEraOnwardsConway $ pubKeyHashToApi <$> pkhs - - mint :: Api.TxMintValue Api.BuildTx ApiEra - mint = case mmint of - Nothing -> Api.TxMintNone - Just (v, xs) -> - Api.TxMintValue Api.MaryEraOnwardsConway (valueToApi v) $ - Api.BuildTxWith $ - Map.fromList - [ ( mintingPolicyApiIdFromWitness p - , gyMintingScriptWitnessToApiPlutusSW - p - (redeemerToApi r) - (Api.ExecutionUnits 0 0) + where + -- Over-estimate the number of key witnesses required for the transaction. + -- We do not provide support for byron key witnesses in our estimate as @Api.makeTransactionBodyAutoBalance@ does not consider them, i.e., count of key witnesses returned here are considered as shelley key witnesses by cardano api. + estimateKeyWitnesses :: Word = + fromIntegral $ + countUnique $ + mapMaybe (extractPaymentPkhFromAddress . utxoAddress) (utxosToList collaterals) + <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxWdrlWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferSCByKey sc]] + <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxCertWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferSCByKey sc]] + <> estimateKeyWitnessesFromInputs ins + <> Set.toList signers + where + extractPaymentPkhFromAddress gyaddr = + addressToPaymentCredential gyaddr >>= \case + GYPaymentCredentialByKey pkh -> Just $ toPubKeyHash pkh + GYPaymentCredentialByScript _ -> Nothing + + preferSCByKey (GYStakeCredentialByKey pkh) = Just $ toPubKeyHash pkh + preferSCByKey _otherwise = Nothing + + countUnique :: Ord a => [a] -> Int + countUnique = Set.size . Set.fromList + + estimateKeyWitnessesFromInputs txInDets = + -- Count key witnesses. + [apkh | txInDet@GYTxInDetailed {gyTxInDet = GYTxIn {gyTxInWitness = GYTxInWitnessKey}} <- txInDets, let gyaddr = gyTxInDetAddress txInDet, Just apkh <- [extractPaymentPkhFromAddress gyaddr]] + ++ + -- Estimate key witnesses required by native scripts. + map toPubKeyHash (Set.toList $ foldl' estimateKeyWitnessesFromNativeScripts mempty txInDets) + where + estimateKeyWitnessesFromNativeScripts acc (gyTxInWitness . gyTxInDet -> GYTxInWitnessSimpleScript gyInSS) = + case gyInSS of + GYInSimpleScript s -> getTotalKeysInSimpleScript s <> acc + GYInReferenceSimpleScript _ s -> getTotalKeysInSimpleScript s <> acc + estimateKeyWitnessesFromNativeScripts acc _ = acc + + inRefs :: Api.TxInsReference Api.BuildTx ApiEra + inRefs = case inRefs' of + [] -> Api.TxInsReferenceNone + _ -> Api.TxInsReference Api.BabbageEraOnwardsConway inRefs' + + inRefs' :: [Api.TxIn] + inRefs' = [txOutRefToApi r | r <- utxosRefs utxosRefInputs] + + -- utxos for inputs + utxosIn :: GYUTxOs + utxosIn = utxosFromList $ utxoFromTxInDetailed <$> ins + + -- Map to lookup information for various utxos. + utxos :: GYUTxOs + utxos = utxosIn <> utxosRefInputs <> collaterals + + outs' :: [Api.S.TxOut Api.S.CtxTx ApiEra] + outs' = txOutToApi <$> outs + + ins' :: [(Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn ApiEra))] + ins' = [txInToApi (isInlineDatum $ gyTxInDetDatum i) (gyTxInDet i) | i <- ins] + + collaterals' :: Api.TxInsCollateral ApiEra + collaterals' = case utxosRefs collaterals of + [] -> Api.TxInsCollateralNone + orefs -> Api.TxInsCollateral Api.AlonzoEraOnwardsConway $ txOutRefToApi <$> orefs + + -- will be filled by makeTransactionBodyAutoBalance + fee :: Api.TxFee ApiEra + fee = Api.TxFeeExplicit Api.ShelleyBasedEraConway $ Ledger.Coin 0 + + lb' :: Api.TxValidityLowerBound ApiEra + lb' = + maybe + Api.TxValidityNoLowerBound + (Api.TxValidityLowerBound Api.AllegraEraOnwardsConway . slotToApi) + lb + + ub' :: Api.TxValidityUpperBound ApiEra + ub' = Api.TxValidityUpperBound Api.ShelleyBasedEraConway $ slotToApi <$> ub + + extra :: Api.TxExtraKeyWitnesses ApiEra + extra = case toList signers of + [] -> Api.TxExtraKeyWitnessesNone + pkhs -> Api.TxExtraKeyWitnesses Api.AlonzoEraOnwardsConway $ pubKeyHashToApi <$> pkhs + + mint :: Api.TxMintValue Api.BuildTx ApiEra + mint = case mmint of + Nothing -> Api.TxMintNone + Just (v, xs) -> + Api.TxMintValue Api.MaryEraOnwardsConway (valueToApi v) $ + Api.BuildTxWith $ + Map.fromList + [ ( mintingPolicyApiIdFromWitness p + , gyMintingScriptWitnessToApiPlutusSW + p + (redeemerToApi r) + (Api.ExecutionUnits 0 0) + ) + | (p, r) <- xs + ] + + -- Putting `TxTotalCollateralNone` & `TxReturnCollateralNone` would have them appropriately calculated by `makeTransactionBodyAutoBalance` but then return collateral it generates is only for ada. To support multi-asset collateral input we therefore calculate correct values ourselves and put appropriate entries here to have `makeTransactionBodyAutoBalance` calculate appropriate overestimated fees. + (dummyTotCol :: Api.TxTotalCollateral ApiEra, dummyRetCol :: Api.TxReturnCollateral Api.CtxTx ApiEra) = + if mempty == collaterals + then + (Api.TxTotalCollateralNone, Api.TxReturnCollateralNone) + else + ( -- Total collateral must be <= lovelaces available in collateral inputs. + Api.TxTotalCollateral retColSup (Ledger.Coin $ fst $ valueSplitAda collateralTotalValue) + , -- Return collateral must be <= what is in collateral inputs. + Api.TxReturnCollateral retColSup $ txOutToApi $ GYTxOut changeAddr collateralTotalValue Nothing Nothing + ) + where + collateralTotalValue :: GYValue + collateralTotalValue = foldMapUTxOs utxoValue collaterals + + txMetadata :: Api.TxMetadataInEra ApiEra + txMetadata = maybe Api.TxMetadataNone toMetaInEra mbTxMetadata + where + toMetaInEra :: GYTxMetadata -> Api.TxMetadataInEra ApiEra + toMetaInEra gymd = + let md = txMetadataToApi gymd + in if md == mempty then Api.TxMetadataNone else Api.TxMetadataInEra Api.ShelleyBasedEraConway md + + wdrls' :: Api.TxWithdrawals Api.BuildTx ApiEra + wdrls' = if wdrls == mempty then Api.TxWithdrawalsNone else Api.TxWithdrawals Api.ShelleyBasedEraConway $ map txWdrlToApi wdrls + + certs' = + if certs == mempty + then Api.TxCertificatesNone + else + let apiCertsFromGY = + foldl' + ( \(accCerts, accWits) cert -> + let (apiCert, mapiWit) = txCertToApi cert + apiWit = maybe Map.empty (uncurry Map.singleton) mapiWit + in (apiCert : accCerts, accWits <> apiWit) ) - | (p, r) <- xs - ] - - -- Putting `TxTotalCollateralNone` & `TxReturnCollateralNone` would have them appropriately calculated by `makeTransactionBodyAutoBalance` but then return collateral it generates is only for ada. To support multi-asset collateral input we therefore calculate correct values ourselves and put appropriate entries here to have `makeTransactionBodyAutoBalance` calculate appropriate overestimated fees. - (dummyTotCol :: Api.TxTotalCollateral ApiEra, dummyRetCol :: Api.TxReturnCollateral Api.CtxTx ApiEra) = - if mempty == collaterals - then - (Api.TxTotalCollateralNone, Api.TxReturnCollateralNone) - else - ( -- Total collateral must be <= lovelaces available in collateral inputs. - Api.TxTotalCollateral retColSup (Ledger.Coin $ fst $ valueSplitAda collateralTotalValue) - , -- Return collateral must be <= what is in collateral inputs. - Api.TxReturnCollateral retColSup $ txOutToApi $ GYTxOut changeAddr collateralTotalValue Nothing Nothing - ) - where - collateralTotalValue :: GYValue - collateralTotalValue = foldMapUTxOs utxoValue collaterals - - txMetadata :: Api.TxMetadataInEra ApiEra - txMetadata = maybe Api.TxMetadataNone toMetaInEra mbTxMetadata - where - toMetaInEra :: GYTxMetadata -> Api.TxMetadataInEra ApiEra - toMetaInEra gymd = - let md = txMetadataToApi gymd - in if md == mempty then Api.TxMetadataNone else Api.TxMetadataInEra Api.ShelleyBasedEraConway md - - wdrls' :: Api.TxWithdrawals Api.BuildTx ApiEra - wdrls' = if wdrls == mempty then Api.TxWithdrawalsNone else Api.TxWithdrawals Api.ShelleyBasedEraConway $ map txWdrlToApi wdrls - - certs' = - if certs == mempty - then Api.TxCertificatesNone - else - let apiCertsFromGY = - foldl' - ( \(accCerts, accWits) cert -> - let (apiCert, mapiWit) = txCertToApi cert - apiWit = maybe Map.empty (uncurry Map.singleton) mapiWit - in (apiCert : accCerts, accWits <> apiWit) - ) - (mempty, mempty) - certs - in Api.TxCertificates Api.ShelleyBasedEraConway (reverse $ fst apiCertsFromGY) $ Api.BuildTxWith (snd apiCertsFromGY) - - unregisteredStakeCredsMap = Map.fromList [(stakeCredentialToApi sc, fromIntegral amt) | GYStakeAddressDeregistrationCertificate amt sc <- map gyTxCertCertificate' certs] - - body :: Api.TxBodyContent Api.BuildTx ApiEra - body = - Api.TxBodyContent - { Api.txIns = ins' - , Api.txInsCollateral = collaterals' - , Api.txInsReference = inRefs - , Api.txOuts = outs' - , Api.txTotalCollateral = dummyTotCol - , Api.txReturnCollateral = dummyRetCol - , Api.txFee = fee - , Api.txValidityLowerBound = lb' - , Api.txValidityUpperBound = ub' - , Api.txMetadata = txMetadata - , Api.txAuxScripts = Api.TxAuxScriptsNone - , Api.txExtraKeyWits = extra - , Api.txProtocolParams = Api.BuildTxWith $ Just $ Api.S.LedgerProtocolParameters pp - , Api.txWithdrawals = wdrls' - , Api.txCertificates = certs' - , Api.txUpdateProposal = Api.TxUpdateProposalNone - , Api.txMintValue = mint - , Api.txScriptValidity = Api.TxScriptValidityNone - , Api.txProposalProcedures = Nothing - , Api.txVotingProcedures = Nothing - , Api.txCurrentTreasuryValue = Nothing -- FIXME:? - , Api.txTreasuryDonation = Nothing - } + (mempty, mempty) + certs + in Api.TxCertificates Api.ShelleyBasedEraConway (reverse $ fst apiCertsFromGY) $ Api.BuildTxWith (snd apiCertsFromGY) + + unregisteredStakeCredsMap = Map.fromList [(stakeCredentialToApi sc, fromIntegral amt) | GYStakeAddressDeregistrationCertificate amt sc <- map gyTxCertCertificate' certs] + + body :: Api.TxBodyContent Api.BuildTx ApiEra + body = + Api.TxBodyContent + { Api.txIns = ins' + , Api.txInsCollateral = collaterals' + , Api.txInsReference = inRefs + , Api.txOuts = outs' + , Api.txTotalCollateral = dummyTotCol + , Api.txReturnCollateral = dummyRetCol + , Api.txFee = fee + , Api.txValidityLowerBound = lb' + , Api.txValidityUpperBound = ub' + , Api.txMetadata = txMetadata + , Api.txAuxScripts = Api.TxAuxScriptsNone + , Api.txExtraKeyWits = extra + , Api.txProtocolParams = Api.BuildTxWith $ Just $ Api.S.LedgerProtocolParameters pp + , Api.txWithdrawals = wdrls' + , Api.txCertificates = certs' + , Api.txUpdateProposal = Api.TxUpdateProposalNone + , Api.txMintValue = mint + , Api.txScriptValidity = Api.TxScriptValidityNone + , Api.txProposalProcedures = Nothing + , Api.txVotingProcedures = Nothing + , Api.txCurrentTreasuryValue = Nothing -- FIXME:? + , Api.txTreasuryDonation = Nothing + } {- | Wraps around 'Api.makeTransactionBodyAutoBalance' just to verify the final ex units and tx size are within limits. @@ -693,7 +693,7 @@ collapseExtraOut apiOut@(Api.TxOut _ outVal _ _) bodyContent@Api.TxBodyContent { in Api.S.createAndValidateTransactionBody Api.ShelleyBasedEraConway $ bodyContent {Api.txOuts = nOuts} - where - (skeletonOuts, changeOuts) = splitAt numSkeletonOuts txOuts + where + (skeletonOuts, changeOuts) = splitAt numSkeletonOuts txOuts type ShelleyBasedConwayEra = Api.S.ShelleyLedgerEra ApiEra diff --git a/src/GeniusYield/Transaction/CBOR.hs b/src/GeniusYield/Transaction/CBOR.hs index 39b705ae..81db323c 100644 --- a/src/GeniusYield/Transaction/CBOR.hs +++ b/src/GeniusYield/Transaction/CBOR.hs @@ -75,11 +75,11 @@ recursiveTermModification f term = TMapI termPairList -> recursiveTermModificationHandler $ TMapI $ bimap (recursiveTermModification f) (recursiveTermModification f) <$> termPairList TTagged word otherTerm -> recursiveTermModificationHandler $ TTagged word $ recursiveTermModification f otherTerm _otherwise -> recursiveTermModificationHandler term - where - recursiveTermModificationHandler nothingHandler = - case f term of - Nothing -> nothingHandler - Just termMod -> if term == termMod then nothingHandler else recursiveTermModification f termMod + where + recursiveTermModificationHandler nothingHandler = + case f term of + Nothing -> nothingHandler + Just termMod -> if term == termMod then nothingHandler else recursiveTermModification f termMod -- | See `simplifyTxCbor`. simplifyTxBodyCbor :: Term -> Term @@ -89,34 +89,34 @@ simplifyTxBodyCbor txBody = -- Second, we'll sort keys in any map. txBodySortedKeys = recursiveTermModification sortMapKeys txBodyDefinite in txBodySortedKeys - where - sortMapKeys :: Term -> Maybe Term - sortMapKeys (TMap keyValsToSort) = - if allSameType - then - Just $ TMap $ sortBy sortingFunction keyValsToSort - else Nothing - where - sortingFunction :: forall b1 b2. (Term, b1) -> (Term, b2) -> Ordering - sortingFunction (TInt a, _) (TInt b, _) = compare a b - sortingFunction (TInteger a, _) (TInteger b, _) = compare a b - sortingFunction (TBytes a, _) (TBytes b, _) = compare (B.length a) (B.length b) <> compare a b - sortingFunction (TString a, _) (TString b, _) = compare (T.length a) (T.length b) <> compare a b - sortingFunction _ _ = error "absurd - sortingFunction" -- We verify that all keys are of the same appropriate type before calling this function. - allSameType = any ($ keyValsToSort) [isTInt, isTInteger, isTBytes, isTString] - where - isTInt = all (\(k, _) -> case k of TInt _ -> True; _ow -> False) - isTInteger = all (\(k, _) -> case k of TInteger _ -> True; _ow -> False) - isTBytes = all (\(k, _) -> case k of TBytes _ -> True; _ow -> False) - isTString = all (\(k, _) -> case k of TString _ -> True; _ow -> False) - sortMapKeys _otherwise = Nothing + where + sortMapKeys :: Term -> Maybe Term + sortMapKeys (TMap keyValsToSort) = + if allSameType + then + Just $ TMap $ sortBy sortingFunction keyValsToSort + else Nothing + where + sortingFunction :: forall b1 b2. (Term, b1) -> (Term, b2) -> Ordering + sortingFunction (TInt a, _) (TInt b, _) = compare a b + sortingFunction (TInteger a, _) (TInteger b, _) = compare a b + sortingFunction (TBytes a, _) (TBytes b, _) = compare (B.length a) (B.length b) <> compare a b + sortingFunction (TString a, _) (TString b, _) = compare (T.length a) (T.length b) <> compare a b + sortingFunction _ _ = error "absurd - sortingFunction" -- We verify that all keys are of the same appropriate type before calling this function. + allSameType = any ($ keyValsToSort) [isTInt, isTInteger, isTBytes, isTString] + where + isTInt = all (\(k, _) -> case k of TInt _ -> True; _ow -> False) + isTInteger = all (\(k, _) -> case k of TInteger _ -> True; _ow -> False) + isTBytes = all (\(k, _) -> case k of TBytes _ -> True; _ow -> False) + isTString = all (\(k, _) -> case k of TString _ -> True; _ow -> False) + sortMapKeys _otherwise = Nothing - makeTermsDefinite :: Term -> Maybe Term - makeTermsDefinite (TBytesI b) = Just $ TBytes $ LBS.toStrict b - makeTermsDefinite (TStringI s) = Just $ TString $ LT.toStrict s - makeTermsDefinite (TListI l) = Just $ TList l - makeTermsDefinite (TMapI keyVals) = Just $ TMap keyVals - makeTermsDefinite _otherwise = Nothing + makeTermsDefinite :: Term -> Maybe Term + makeTermsDefinite (TBytesI b) = Just $ TBytes $ LBS.toStrict b + makeTermsDefinite (TStringI s) = Just $ TString $ LT.toStrict s + makeTermsDefinite (TListI l) = Just $ TList l + makeTermsDefinite (TMapI keyVals) = Just $ TMap keyVals + makeTermsDefinite _otherwise = Nothing -- | This `GYTxBody` doesn't represent @transaction_body@ as mentioned in [CDDL](https://github.com/input-output-hk/cardano-ledger/blob/master/eras/babbage/test-suite/cddl-files/babbage.cddl) specification, it's API's internal type to represent transaction without signing key witnesses. However `GYTx` does represent `transaction` as defined in specification. We therefore obtain `GYTx` and work with it. Here we need an invariant, which is if we receive our simplified `GYTx` transaction, then obtaining `GYTxBody` via `getTxBody` and obtaining `GYTx` back via `unsignedTx` should have the same serialisation for the modifications to CBOR encoding we do here. simplifyGYTxBodyCbor :: GYTxBody -> Either CborSimplificationError GYTxBody diff --git a/src/GeniusYield/Transaction/CoinSelection.hs b/src/GeniusYield/Transaction/CoinSelection.hs index f22b19aa..42980bf0 100644 --- a/src/GeniusYield/Transaction/CoinSelection.hs +++ b/src/GeniusYield/Transaction/CoinSelection.hs @@ -120,7 +120,7 @@ a positive amount of ada. -} selectInputs :: forall m v. - (MonadRandom m) => + MonadRandom m => GYCoinSelectionEnv v -> GYCoinSelectionStrategy -> ExceptT GYBalancingError m ([GYTxInDetailed v], [GYTxOut v]) @@ -167,17 +167,17 @@ selectInputs | not $ isEmptyValue tokenChange ] pure (additionalInputForReplayProtectionAsList <> addIns, changeOuts) - where - missing :: GYValue -> Map GYAssetClass Natural - missing v = foldl' f Map.empty $ valueToList v - where - f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural - f m (ac, n) - | n <= 0 = m - | otherwise = Map.insert ac (fromIntegral n) m - - removeAda :: GYValue -> GYValue - removeAda = snd . valueSplitAda + where + missing :: GYValue -> Map GYAssetClass Natural + missing v = foldl' f Map.empty $ valueToList v + where + f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural + f m (ac, n) + | n <= 0 = m + | otherwise = Map.insert ac (fromIntegral n) m + + removeAda :: GYValue -> GYValue + removeAda = snd . valueSplitAda selectInputs GYCoinSelectionEnv { existingInputs @@ -217,48 +217,48 @@ selectInputs -- Set of additional inputs chosen by the balancer that should be added to the transaction. addIns = foldl' foldHelper [] inputsSelected pure (addIns, changeOuts) - where - selectionConstraints = - CBalance.SelectionConstraints - { tokenBundleSizeAssessor = - tokenBundleSizeAssessor $ - CWallet.TxSize maxValueSize - , computeMinimumAdaQuantity = \addr tkMap -> do - -- This function is ran for generated change outputs which do not have datum & reference script. - -- This first parameter can actually be ignored as it will always be @toCWalletAddress changeAddr@. - CWallet.Coin $ - minimumUTxOF - GYTxOut - { gyTxOutAddress = fromCWalletAddress addr - , gyTxOutValue = fromTokenMap tkMap - , gyTxOutDatum = Nothing - , gyTxOutRefS = Nothing - } - , {- This field essentially takes care of tx fees. - - For simplicity, we simply use the extraLovelace parameter. - -} - computeMinimumCost = const $ CWallet.Coin extraLovelace - , maximumOutputAdaQuantity = CWallet.txOutMaxCoin - , maximumOutputTokenQuantity = CWallet.txOutMaxTokenQuantity - , maximumLengthChangeAddress = toCWalletAddress changeAddr -- Since our change address is fixed. - , nullAddress = CWallet.Address "" - } - selectionParams = - CBalance.SelectionParams - { assetsToMint = toTokenMap mintedVal - , assetsToBurn = toTokenMap burnedVal - , extraCoinSource = CWallet.Coin adaSource - , extraCoinSink = CWallet.Coin adaSink - , outputsToCover = map (bimap toCWalletAddress toTokenBundle) requiredOutputs - , utxoAvailable = CWallet.fromIndexPair (ownUtxosIndex, existingInpsIndex) -- `fromIndexPair` would actually make first element to be @ownUtxosIndex `UTxOIndex.difference` existingInpsIndex@. - , selectionStrategy = case cstrat of - GYRandomImproveMultiAsset -> CBalance.SelectionStrategyOptimal - _ -> CBalance.SelectionStrategyMinimal - } - (mintedVal, burnedVal) = valueSplitSign mintValue - ownUtxosIndex = utxosToUtxoIndex ownUtxos - existingInpsIndex = txInDetailedToUtxoIndex existingInputs + where + selectionConstraints = + CBalance.SelectionConstraints + { tokenBundleSizeAssessor = + tokenBundleSizeAssessor $ + CWallet.TxSize maxValueSize + , computeMinimumAdaQuantity = \addr tkMap -> do + -- This function is ran for generated change outputs which do not have datum & reference script. + -- This first parameter can actually be ignored as it will always be @toCWalletAddress changeAddr@. + CWallet.Coin $ + minimumUTxOF + GYTxOut + { gyTxOutAddress = fromCWalletAddress addr + , gyTxOutValue = fromTokenMap tkMap + , gyTxOutDatum = Nothing + , gyTxOutRefS = Nothing + } + , {- This field essentially takes care of tx fees. + + For simplicity, we simply use the extraLovelace parameter. + -} + computeMinimumCost = const $ CWallet.Coin extraLovelace + , maximumOutputAdaQuantity = CWallet.txOutMaxCoin + , maximumOutputTokenQuantity = CWallet.txOutMaxTokenQuantity + , maximumLengthChangeAddress = toCWalletAddress changeAddr -- Since our change address is fixed. + , nullAddress = CWallet.Address "" + } + selectionParams = + CBalance.SelectionParams + { assetsToMint = toTokenMap mintedVal + , assetsToBurn = toTokenMap burnedVal + , extraCoinSource = CWallet.Coin adaSource + , extraCoinSink = CWallet.Coin adaSink + , outputsToCover = map (bimap toCWalletAddress toTokenBundle) requiredOutputs + , utxoAvailable = CWallet.fromIndexPair (ownUtxosIndex, existingInpsIndex) -- `fromIndexPair` would actually make first element to be @ownUtxosIndex `UTxOIndex.difference` existingInpsIndex@. + , selectionStrategy = case cstrat of + GYRandomImproveMultiAsset -> CBalance.SelectionStrategyOptimal + _ -> CBalance.SelectionStrategyMinimal + } + (mintedVal, burnedVal) = valueSplitSign mintValue + ownUtxosIndex = utxosToUtxoIndex ownUtxos + existingInpsIndex = txInDetailedToUtxoIndex existingInputs computeTokenBundleSerializedLengthBytes :: CTokenBundle.TokenBundle -> CWallet.TxSize computeTokenBundleSerializedLengthBytes = @@ -268,9 +268,9 @@ computeTokenBundleSerializedLengthBytes = . CBOR.serialize' (eraProtVerHigh @Conway) . Api.S.toMaryValue . toCardanoValue - where - safeCast :: Int -> Natural - safeCast = fromIntegral + where + safeCast :: Int -> Natural + safeCast = fromIntegral selectInputsLegacy :: -- | Set of own utxos to select additional inputs from. @@ -281,39 +281,39 @@ selectInputsLegacy :: [GYTxInDetailed v] -> Either GYBalancingError ([GYTxInDetailed v], GYValue) selectInputsLegacy ownUtxos targetOut existingIns = go targetOut [] mempty $ utxosToList ownUtxos - where - inRefs = map (gyTxInTxOutRef . gyTxInDet) existingIns - ownValueMap :: Map GYTxOutRef GYValue - ownValueMap = mapUTxOs utxoValue ownUtxos - - go :: Map GYAssetClass Natural -> [GYTxInDetailed v] -> GYValue -> [GYUTxO] -> Either GYBalancingError ([GYTxInDetailed v], GYValue) - go m addIns addVal _ - | Map.null m = Right (addIns, addVal) - go m _ _ [] = Left $ GYBalancingErrorInsufficientFunds $ valueFromList [(ac, toInteger n) | (ac, n) <- Map.toList m] - go m addIns addVal (utxo : ys) - | utxoRef utxo `elem` inRefs = go m addIns addVal ys - | otherwise = - let v = ownValueMap Map.! utxoRef utxo - m' = foldl' f m $ valueToList v - where - f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural - f m'' (ac, n) = - let - o = fromIntegral n - in - case Map.lookup ac m'' of - Nothing -> m'' - Just n' - | n' <= o -> Map.delete ac m'' - | otherwise -> Map.insert ac (n' - o) m'' - in if m' == m - then go m addIns addVal ys - else - go - m' - (utxoAsPubKeyInp utxo : addIns) - (addVal <> v) - ys + where + inRefs = map (gyTxInTxOutRef . gyTxInDet) existingIns + ownValueMap :: Map GYTxOutRef GYValue + ownValueMap = mapUTxOs utxoValue ownUtxos + + go :: Map GYAssetClass Natural -> [GYTxInDetailed v] -> GYValue -> [GYUTxO] -> Either GYBalancingError ([GYTxInDetailed v], GYValue) + go m addIns addVal _ + | Map.null m = Right (addIns, addVal) + go m _ _ [] = Left $ GYBalancingErrorInsufficientFunds $ valueFromList [(ac, toInteger n) | (ac, n) <- Map.toList m] + go m addIns addVal (utxo : ys) + | utxoRef utxo `elem` inRefs = go m addIns addVal ys + | otherwise = + let v = ownValueMap Map.! utxoRef utxo + m' = foldl' f m $ valueToList v + where + f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural + f m'' (ac, n) = + let + o = fromIntegral n + in + case Map.lookup ac m'' of + Nothing -> m'' + Just n' + | n' <= o -> Map.delete ac m'' + | otherwise -> Map.insert ac (n' - o) m'' + in if m' == m + then go m addIns addVal ys + else + go + m' + (utxoAsPubKeyInp utxo : addIns) + (addVal <> v) + ys ------------------------------------------------------------------------------- -- Utilities @@ -332,33 +332,33 @@ utxoAsPubKeyInp GYUTxO {utxoRef, utxoAddress, utxoValue, utxoOutDatum, utxoRefSc tokenBundleSizeAssessor :: CWallet.TxSize -> CWallet.TokenBundleSizeAssessor tokenBundleSizeAssessor maxSize = CWallet.TokenBundleSizeAssessor {..} - where - assessTokenBundleSize tb - | serializedLengthBytes <= maxSize = - CWallet.TokenBundleSizeWithinLimit - | otherwise = - CWallet.TokenBundleSizeExceedsLimit - where - serializedLengthBytes :: CWallet.TxSize - serializedLengthBytes = computeTokenBundleSerializedLengthBytes tb + where + assessTokenBundleSize tb + | serializedLengthBytes <= maxSize = + CWallet.TokenBundleSizeWithinLimit + | otherwise = + CWallet.TokenBundleSizeExceedsLimit + where + serializedLengthBytes :: CWallet.TxSize + serializedLengthBytes = computeTokenBundleSerializedLengthBytes tb toCardanoValue :: CTokenBundle.TokenBundle -> Api.S.Value toCardanoValue tb = Api.S.valueFromList $ (Api.S.AdaAssetId, coinToQuantity coin) : map (bimap toCardanoAssetId toQuantity) bundle - where - (coin, bundle) = CTokenBundle.toFlatList tb - toCardanoAssetId (CTokenBundle.AssetId pid name) = - Api.S.AssetId (toCardanoPolicyId pid) (toCardanoAssetName name) + where + (coin, bundle) = CTokenBundle.toFlatList tb + toCardanoAssetId (CTokenBundle.AssetId pid name) = + Api.S.AssetId (toCardanoPolicyId pid) (toCardanoAssetName name) - toCardanoAssetName :: CWallet.AssetName -> Api.S.AssetName - toCardanoAssetName (CWallet.UnsafeAssetName tn) = - either (\e -> error $ "toCardanoValue: unable to deserialise, error: " <> show e) id $ - Api.S.deserialiseFromRawBytes Api.S.AsAssetName tn + toCardanoAssetName :: CWallet.AssetName -> Api.S.AssetName + toCardanoAssetName (CWallet.UnsafeAssetName tn) = + either (\e -> error $ "toCardanoValue: unable to deserialise, error: " <> show e) id $ + Api.S.deserialiseFromRawBytes Api.S.AsAssetName tn - coinToQuantity = fromIntegral . CWallet.unCoin - toQuantity = fromIntegral . CWallet.unTokenQuantity + coinToQuantity = fromIntegral . CWallet.unCoin + toQuantity = fromIntegral . CWallet.unTokenQuantity toCardanoPolicyId :: CWallet.TokenPolicyId -> Api.S.PolicyId toCardanoPolicyId (CWallet.UnsafeTokenPolicyId (CWallet.Hash pid)) = @@ -381,24 +381,24 @@ fromTokenMap = toWalletAssetId :: GYAssetClass -> CTokenBundle.AssetId toWalletAssetId GYLovelace = error "toWalletAssetId: unable to deserialize" toWalletAssetId tkn@(GYToken policyId (GYTokenName tokenName)) = CTokenBundle.AssetId tokenPolicy nTokenName - where - tokenPolicy = either (customError tkn) id $ fromText $ mintingPolicyIdToText policyId - nTokenName = either (customError tkn) id $ CWallet.fromByteString tokenName - customError t = error $ printf "toWalletAssetId: unable to deserialize \n %s" t + where + tokenPolicy = either (customError tkn) id $ fromText $ mintingPolicyIdToText policyId + nTokenName = either (customError tkn) id $ CWallet.fromByteString tokenName + customError t = error $ printf "toWalletAssetId: unable to deserialize \n %s" t fromWalletAssetId :: CTokenBundle.AssetId -> GYAssetClass fromWalletAssetId (CTokenBundle.AssetId tokenPolicy nTokenName) = GYToken policyId tkName - where - policyId = fromRight customError $ mintingPolicyIdFromText $ toText tokenPolicy - tkName = fromMaybe customError $ tokenNameFromBS $ CWallet.unAssetName nTokenName - customError = error "fromWalletAssetId: unable to deserialize" + where + policyId = fromRight customError $ mintingPolicyIdFromText $ toText tokenPolicy + tkName = fromMaybe customError $ tokenNameFromBS $ CWallet.unAssetName nTokenName + customError = error "fromWalletAssetId: unable to deserialize" toTokenBundle :: GYValue -> CTokenBundle.TokenBundle toTokenBundle v = CTokenBundle.fromCoin coins `CTokenBundle.add` CTokenBundle.fromTokenMap (toTokenMap tokens) - where - coins = fromMaybe customError $ CWallet.fromIntegralMaybe lov - (lov, tokens) = valueSplitAda v - customError = error "toTokenBundle: unable to deserialize" + where + coins = fromMaybe customError $ CWallet.fromIntegralMaybe lov + (lov, tokens) = valueSplitAda v + customError = error "toTokenBundle: unable to deserialize" fromTokenBundle :: CTokenBundle.TokenBundle -> GYValue fromTokenBundle (CTokenBundle.TokenBundle (CWallet.Coin n) tkMap) = valueFromLovelace (toInteger n) <> fromTokenMap tkMap @@ -413,13 +413,13 @@ utxoToTuple , utxoAddress , utxoValue } = (wUtxo, bundle) - where - wUtxo = - CBalanceInternal.WalletUTxO - { txIn = toCWalletTxIn utxoRef - , address = toCWalletAddress utxoAddress - } - bundle = toTokenBundle utxoValue + where + wUtxo = + CBalanceInternal.WalletUTxO + { txIn = toCWalletTxIn utxoRef + , address = toCWalletAddress utxoAddress + } + bundle = toTokenBundle utxoValue txInDetailedToUtxoIndex :: [GYTxInDetailed v] -> CWallet.UTxOIndex CBalanceInternal.WalletUTxO txInDetailedToUtxoIndex = CWallet.fromSequence . map txInDetailedToTuple @@ -431,21 +431,21 @@ txInDetailedToTuple , gyTxInDetAddress , gyTxInDetValue } = (wUtxo, bundle) - where - wUtxo = - CBalanceInternal.WalletUTxO - { txIn = toCWalletTxIn $ gyTxInTxOutRef gyTxInDet - , address = toCWalletAddress gyTxInDetAddress - } - bundle = toTokenBundle gyTxInDetValue + where + wUtxo = + CBalanceInternal.WalletUTxO + { txIn = toCWalletTxIn $ gyTxInTxOutRef gyTxInDet + , address = toCWalletAddress gyTxInDetAddress + } + bundle = toTokenBundle gyTxInDetValue toCWalletAddress :: GYAddress -> CWallet.Address toCWalletAddress = CWallet.Address . Api.serialiseToRawBytes . addressToApi fromCWalletAddress :: CWallet.Address -> GYAddress fromCWalletAddress (CWallet.Address bs) = either customError addressFromApi $ Api.deserialiseFromRawBytes Api.AsAddressAny bs - where - customError e = error $ "fromCWalletAddress: unable to deserialize, error: " <> show e + where + customError e = error $ "fromCWalletAddress: unable to deserialize, error: " <> show e toCWalletTxIn :: GYTxOutRef -> CWallet.TxIn toCWalletTxIn ref = @@ -453,16 +453,16 @@ toCWalletTxIn ref = { inputId = nTxId , inputIx = fromIntegral txIx } - where - (txId, txIx) = txOutRefToTuple ref - nTxId = either customError id $ fromText $ Text.pack $ show txId - customError = error "toCWalletTxIn: unable to deserialise" + where + (txId, txIx) = txOutRefToTuple ref + nTxId = either customError id $ fromText $ Text.pack $ show txId + customError = error "toCWalletTxIn: unable to deserialise" fromCWalletTxIn :: CWallet.TxIn -> GYTxOutRef fromCWalletTxIn CWallet.TxIn {inputId, inputIx} = txOutRefFromTuple (txId, fromIntegral inputIx) - where - txId = fromMaybe customError . txIdFromHex . Text.unpack $ toText inputId - customError = error "fromCWalletTxIn: unable to deserialise txId" + where + txId = fromMaybe customError . txIdFromHex . Text.unpack $ toText inputId + customError = error "fromCWalletTxIn: unable to deserialise txId" fromCWalletBalancingError :: CBalanceInternal.SelectionBalanceError ctx -> GYBalancingError fromCWalletBalancingError (CBalance.BalanceInsufficient (CBalance.BalanceInsufficientError _ _ delta)) = diff --git a/src/GeniusYield/Transaction/Common.hs b/src/GeniusYield/Transaction/Common.hs index d1b9c084..d4d16cca 100644 --- a/src/GeniusYield/Transaction/Common.hs +++ b/src/GeniusYield/Transaction/Common.hs @@ -120,7 +120,7 @@ data GYBuildTxError GYBuildTxNoSuitableCollateral | GYBuildTxCborSimplificationError !CborSimplificationError | GYBuildTxCollapseExtraOutError !Api.TxBodyError - deriving stock (Show) + deriving stock Show ------------------------------------------------------------------------------- -- Transaction Utilities @@ -134,17 +134,17 @@ minimumUTxO pp txOut = adjustTxOut :: (GYTxOut v -> Natural) -> GYTxOut v -> GYTxOut v adjustTxOut minimumUTxOF = helper - where - helper txOut = - let v = gyTxOutValue txOut - needed = minimumUTxOF txOut - contained = extractLovelace $ valueToApi v - in if needed <= contained - then txOut - else - let v' = valueFromLovelace (fromIntegral $ needed - contained) <> v - txOut' = txOut {gyTxOutValue = v'} - in helper txOut' + where + helper txOut = + let v = gyTxOutValue txOut + needed = minimumUTxOF txOut + contained = extractLovelace $ valueToApi v + in if needed <= contained + then txOut + else + let v' = valueFromLovelace (fromIntegral $ needed - contained) <> v + txOut' = txOut {gyTxOutValue = v'} + in helper txOut' extractLovelace :: Api.Value -> Natural extractLovelace v = case Api.selectLovelace v of Ledger.Coin n -> fromIntegral $ max 0 n diff --git a/src/GeniusYield/TxBuilder.hs b/src/GeniusYield/TxBuilder.hs index 129f70f2..3ec1f2d7 100644 --- a/src/GeniusYield/TxBuilder.hs +++ b/src/GeniusYield/TxBuilder.hs @@ -29,23 +29,23 @@ import GeniusYield.Imports import GeniusYield.Types -- | Query the balance at given address. -queryBalance :: (GYTxQueryMonad m) => GYAddress -> m GYValue +queryBalance :: GYTxQueryMonad m => GYAddress -> m GYValue queryBalance addr = foldMapUTxOs utxoValue <$> utxosAtAddress addr Nothing -- | Query the balances at given addresses. -queryBalances :: (GYTxQueryMonad m) => [GYAddress] -> m GYValue +queryBalances :: GYTxQueryMonad m => [GYAddress] -> m GYValue queryBalances addrs = foldMapUTxOs utxoValue <$> utxosAtAddresses addrs {- | Query the txoutrefs at given address with ADA-only values. Useful for finding a txoutref to be used as collateral. -} -getAdaOnlyUTxO :: (GYTxQueryMonad m) => GYAddress -> m [(GYTxOutRef, Natural)] +getAdaOnlyUTxO :: GYTxQueryMonad m => GYAddress -> m [(GYTxOutRef, Natural)] getAdaOnlyUTxO addr = adaOnlyUTxOPure <$> utxosAtAddress addr Nothing -- | Get a UTxO suitable for use as collateral. getCollateral' :: - (GYTxQueryMonad m) => + GYTxQueryMonad m => -- | The address where to look. GYAddress -> -- | The minimal amount of lovelace required as collateral. @@ -60,7 +60,7 @@ getCollateral' addr minCollateral = do -- | Get an UTxO suitable for use as collateral. getCollateral :: - (GYTxQueryMonad m) => + GYTxQueryMonad m => -- | The address where to look. GYAddress -> -- | The minimal amount of lovelace required as collateral. @@ -75,16 +75,16 @@ getCollateral addr minCollateral = do adaOnlyUTxOPure :: GYUTxOs -> [(GYTxOutRef, Natural)] adaOnlyUTxOPure = Map.toList . mapMaybeUTxOs (valueIsPositiveAda . utxoValue) - where - valueIsPositiveAda :: GYValue -> Maybe Natural - valueIsPositiveAda v = case valueSplitAda v of - (n, v') | n > 0, isEmptyValue v' -> Just (fromInteger n) - _ -> Nothing + where + valueIsPositiveAda :: GYValue -> Maybe Natural + valueIsPositiveAda v = case valueSplitAda v of + (n, v') | n > 0, isEmptyValue v' -> Just (fromInteger n) + _ -> Nothing {- | Calculate how much balance is the given transaction is moving to given pubkeyhash address(es). -} -getTxBalance :: (GYTxQueryMonad m) => GYPubKeyHash -> GYTx -> m GYValue +getTxBalance :: GYTxQueryMonad m => GYPubKeyHash -> GYTx -> m GYValue getTxBalance pkh tx = do let Api.TxBody content = Api.getTxBody $ txToApi tx ins = txOutRefFromApi . fst <$> Api.txIns content @@ -97,11 +97,11 @@ getTxBalance pkh tx = do utxos <- utxosAtTxOutRefs ins let inValue = foldMapUTxOs f utxos return $ outValue `valueMinus` inValue - where - isRelevantAddress :: GYAddress -> Bool - isRelevantAddress addr = Just pkh == addressToPubKeyHash addr + where + isRelevantAddress :: GYAddress -> Bool + isRelevantAddress addr = Just pkh == addressToPubKeyHash addr - f :: GYUTxO -> GYValue - f utxo - | isRelevantAddress $ utxoAddress utxo = utxoValue utxo - | otherwise = mempty + f :: GYUTxO -> GYValue + f utxo + | isRelevantAddress $ utxoAddress utxo = utxoValue utxo + | otherwise = mempty diff --git a/src/GeniusYield/TxBuilder/Class.hs b/src/GeniusYield/TxBuilder/Class.hs index 9a53572b..ea7d3629 100644 --- a/src/GeniusYield/TxBuilder/Class.hs +++ b/src/GeniusYield/TxBuilder/Class.hs @@ -197,19 +197,19 @@ class (Default (TxBuilderStrategy m), GYTxSpecialQueryMonad m, GYTxUserQueryMona buildTxBodyChainingWithStrategy = buildTxBodyChainingWithStrategy' -- | 'buildTxBodyWithStrategy' with the default coin selection strategy. -buildTxBody :: forall v m. (GYTxBuilderMonad m) => GYTxSkeleton v -> m GYTxBody +buildTxBody :: forall v m. GYTxBuilderMonad m => GYTxSkeleton v -> m GYTxBody buildTxBody = buildTxBodyWithStrategy def -- | 'buildTxBodyParallelWithStrategy' with the default coin selection strategy. -buildTxBodyParallel :: forall v m. (GYTxBuilderMonad m) => [GYTxSkeleton v] -> m GYTxBuildResult +buildTxBodyParallel :: forall v m. GYTxBuilderMonad m => [GYTxSkeleton v] -> m GYTxBuildResult buildTxBodyParallel = buildTxBodyParallelWithStrategy def -- | 'buildTxBodyChainingWithStrategy' with the default coin selection strategy. -buildTxBodyChaining :: forall v m. (GYTxBuilderMonad m) => [GYTxSkeleton v] -> m GYTxBuildResult +buildTxBodyChaining :: forall v m. GYTxBuilderMonad m => [GYTxSkeleton v] -> m GYTxBuildResult buildTxBodyChaining = buildTxBodyChainingWithStrategy def -- | Class of monads for interacting with the blockchain using transactions. -class (GYTxBuilderMonad m) => GYTxMonad m where +class GYTxBuilderMonad m => GYTxMonad m where -- | Sign a transaction body with the user payment key to produce a transaction with witnesses. -- -- /Note:/ The key is not meant to be exposed to the monad, so it is only held @@ -244,10 +244,10 @@ class (GYTxBuilderMonad m) => GYTxMonad m where -- by the identified transaction. awaitTxConfirmed' :: GYAwaitTxParameters -> GYTxId -> m () -signTxBodyImpl :: (GYTxMonad m) => m GYPaymentSigningKey -> GYTxBody -> m GYTx +signTxBodyImpl :: GYTxMonad m => m GYPaymentSigningKey -> GYTxBody -> m GYTx signTxBodyImpl kM txBody = signGYTxBody txBody . (: []) <$> kM -signTxBodyWithStakeImpl :: (GYTxMonad m) => m (GYPaymentSigningKey, Maybe GYStakeSigningKey) -> GYTxBody -> m GYTx +signTxBodyWithStakeImpl :: GYTxMonad m => m (GYPaymentSigningKey, Maybe GYStakeSigningKey) -> GYTxBody -> m GYTx signTxBodyWithStakeImpl kM txBody = (\(pKey, sKey) -> signGYTxBody txBody $ GYSomeSigningKey pKey : maybeToList (GYSomeSigningKey <$> sKey)) <$> kM -- | Class of monads that can simulate a "game" between different users interacting with transactions. @@ -288,47 +288,47 @@ will be automatically inferred. -} -- | > waitUntilSlot_ = void . waitUntilSlot -waitUntilSlot_ :: (GYTxQueryMonad m) => GYSlot -> m () +waitUntilSlot_ :: GYTxQueryMonad m => GYSlot -> m () waitUntilSlot_ = void . waitUntilSlot -- | Wait until the chain tip has progressed by N slots. -waitNSlots :: (GYTxQueryMonad m) => Word64 -> m GYSlot +waitNSlots :: GYTxQueryMonad m => Word64 -> m GYSlot waitNSlots (slotFromWord64 -> n) = do -- FIXME: Does this need to be an absolute slot getter instead? currentSlot <- slotOfCurrentBlock waitUntilSlot . slotFromApi $ currentSlot `addSlots` n - where - addSlots = (+) `on` slotToApi + where + addSlots = (+) `on` slotToApi -- | > waitNSlots_ = void . waitNSlots -waitNSlots_ :: (GYTxQueryMonad m) => Word64 -> m () +waitNSlots_ :: GYTxQueryMonad m => Word64 -> m () waitNSlots_ = void . waitNSlots -- | > submitTx_ = void . submitTx -submitTx_ :: (GYTxMonad m) => GYTx -> m () +submitTx_ :: GYTxMonad m => GYTx -> m () submitTx_ = void . submitTx -- | > submitTxConfirmed_ = void . submitTxConfirmed -submitTxConfirmed_ :: (GYTxMonad m) => GYTx -> m () +submitTxConfirmed_ :: GYTxMonad m => GYTx -> m () submitTxConfirmed_ = void . submitTxConfirmed -- | 'submitTxConfirmed'' with default tx waiting parameters. -submitTxConfirmed :: (GYTxMonad m) => GYTx -> m GYTxId +submitTxConfirmed :: GYTxMonad m => GYTx -> m GYTxId submitTxConfirmed = submitTxConfirmed' def -- | > submitTxConfirmed'_ p = void . submitTxConfirmed' p -submitTxConfirmed'_ :: (GYTxMonad m) => GYAwaitTxParameters -> GYTx -> m () +submitTxConfirmed'_ :: GYTxMonad m => GYAwaitTxParameters -> GYTx -> m () submitTxConfirmed'_ awaitParams = void . submitTxConfirmed' awaitParams -- | Equivalent to a call to 'submitTx' and then a call to 'awaitTxConfirmed'' with submitted tx id. -submitTxConfirmed' :: (GYTxMonad m) => GYAwaitTxParameters -> GYTx -> m GYTxId +submitTxConfirmed' :: GYTxMonad m => GYAwaitTxParameters -> GYTx -> m GYTxId submitTxConfirmed' awaitParams tx = do txId <- submitTx tx awaitTxConfirmed' awaitParams txId pure txId -- | Wait for a _recently_ submitted transaction to be confirmed, with default waiting parameters. -awaitTxConfirmed :: (GYTxMonad m) => GYTxId -> m () +awaitTxConfirmed :: GYTxMonad m => GYTxId -> m () awaitTxConfirmed = awaitTxConfirmed' def -- | > submitTxBody_ t = void . submitTxBody t @@ -351,10 +351,10 @@ Equivalent to a call to 'signGYTxBody', followed by a call to 'submitTxConfirmed submitTxBodyConfirmed :: forall a m. (GYTxMonad m, ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> m GYTxId submitTxBodyConfirmed txBody = submitTxConfirmed . signGYTxBody txBody -signAndSubmitConfirmed_ :: (GYTxMonad m) => GYTxBody -> m () +signAndSubmitConfirmed_ :: GYTxMonad m => GYTxBody -> m () signAndSubmitConfirmed_ = void . signAndSubmitConfirmed -signAndSubmitConfirmed :: (GYTxMonad m) => GYTxBody -> m GYTxId +signAndSubmitConfirmed :: GYTxMonad m => GYTxBody -> m GYTxId signAndSubmitConfirmed txBody = signTxBody txBody >>= submitTxConfirmed ------------------------------------------------------------------------------- @@ -381,25 +381,25 @@ Since these wrapper data types are usage specific, and 'GYTxGameMonad' instances "overarching base" type, we do not provide these instances and users may define them if necessary. -} -instance (GYTxBuilderMonad m) => GYTxBuilderMonad (RandT g m) where +instance GYTxBuilderMonad m => GYTxBuilderMonad (RandT g m) where type TxBuilderStrategy (RandT g m) = TxBuilderStrategy m buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x -instance (GYTxMonad m) => GYTxMonad (RandT g m) where +instance GYTxMonad m => GYTxMonad (RandT g m) where signTxBody = lift . signTxBody signTxBodyWithStake = lift . signTxBodyWithStake submitTx = lift . submitTx awaitTxConfirmed' p = lift . awaitTxConfirmed' p -instance (GYTxBuilderMonad m) => GYTxBuilderMonad (ReaderT env m) where +instance GYTxBuilderMonad m => GYTxBuilderMonad (ReaderT env m) where type TxBuilderStrategy (ReaderT env m) = TxBuilderStrategy m buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x -instance (GYTxMonad m) => GYTxMonad (ReaderT env m) where +instance GYTxMonad m => GYTxMonad (ReaderT env m) where signTxBody = lift . signTxBody signTxBodyWithStake = lift . signTxBodyWithStake submitTx = lift . submitTx @@ -411,25 +411,25 @@ instance (GYTxMonad m) => GYTxMonad (ReaderT env m) where -- See: https://github.com/haskell-effectful/effectful/blob/master/transformers.md ------------------------------------------------------------------------------- -instance (GYTxBuilderMonad m) => GYTxBuilderMonad (Strict.StateT s m) where +instance GYTxBuilderMonad m => GYTxBuilderMonad (Strict.StateT s m) where type TxBuilderStrategy (Strict.StateT s m) = TxBuilderStrategy m buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x -instance (GYTxMonad m) => GYTxMonad (Strict.StateT s m) where +instance GYTxMonad m => GYTxMonad (Strict.StateT s m) where signTxBody = lift . signTxBody signTxBodyWithStake = lift . signTxBodyWithStake submitTx = lift . submitTx awaitTxConfirmed' p = lift . awaitTxConfirmed' p -instance (GYTxBuilderMonad m) => GYTxBuilderMonad (Lazy.StateT s m) where +instance GYTxBuilderMonad m => GYTxBuilderMonad (Lazy.StateT s m) where type TxBuilderStrategy (Lazy.StateT s m) = TxBuilderStrategy m buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x -instance (GYTxMonad m) => GYTxMonad (Lazy.StateT s m) where +instance GYTxMonad m => GYTxMonad (Lazy.StateT s m) where signTxBody = lift . signTxBody signTxBodyWithStake = lift . signTxBodyWithStake submitTx = lift . submitTx @@ -472,11 +472,11 @@ instance (GYTxMonad m, Monoid w) => GYTxMonad (Lazy.WriterT w m) where awaitTxConfirmed' p = lift . awaitTxConfirmed' p -- | A version of 'lookupDatum' that raises 'GYNoDatumForHash' if the datum is not found. -lookupDatum' :: (GYTxQueryMonad m) => GYDatumHash -> m GYDatum +lookupDatum' :: GYTxQueryMonad m => GYDatumHash -> m GYDatum lookupDatum' h = lookupDatum h >>= maybe (throwError . GYQueryDatumException $ GYNoDatumForHash h) pure -- | A version of 'utxoAtTxOutRef' that raises 'GYNoUtxoAtRef' if the utxo is not found. -utxoAtTxOutRef' :: (GYTxQueryMonad m) => GYTxOutRef -> m GYUTxO +utxoAtTxOutRef' :: GYTxQueryMonad m => GYTxOutRef -> m GYUTxO utxoAtTxOutRef' ref = utxoAtTxOutRef ref >>= maybe @@ -484,7 +484,7 @@ utxoAtTxOutRef' ref = pure -- | A version of 'utxoAtTxOutRefWithDatum' that raises 'GYNoUtxoAtRef' if the utxo is not found. -utxoAtTxOutRefWithDatum' :: (GYTxQueryMonad m) => GYTxOutRef -> m (GYUTxO, Maybe GYDatum) +utxoAtTxOutRefWithDatum' :: GYTxQueryMonad m => GYTxOutRef -> m (GYUTxO, Maybe GYDatum) utxoAtTxOutRefWithDatum' ref = utxoAtTxOutRefWithDatum ref >>= maybe @@ -492,7 +492,7 @@ utxoAtTxOutRefWithDatum' ref = pure -- | Returns some UTxO present in wallet which doesn't have reference script. -someUTxOWithoutRefScript :: (GYTxUserQueryMonad m) => m GYTxOutRef +someUTxOWithoutRefScript :: GYTxUserQueryMonad m => m GYTxOutRef someUTxOWithoutRefScript = do utxosToConsider <- utxosRemoveRefScripts <$> availableUTxOs addrs <- ownAddresses @@ -505,25 +505,25 @@ someUTxOWithoutRefScript = do ------------------------------------------------------------------------------- -- | Get the starting 'GYTime' of a 'GYSlot' in 'GYTxMonad'. -slotToBeginTime :: (GYTxQueryMonad f) => GYSlot -> f GYTime +slotToBeginTime :: GYTxQueryMonad f => GYSlot -> f GYTime slotToBeginTime x = flip slotToBeginTimePure x <$> slotConfig -- | Get the ending 'GYTime' of a 'GYSlot' (inclusive) in 'GYTxMonad'. -slotToEndTime :: (GYTxQueryMonad f) => GYSlot -> f GYTime +slotToEndTime :: GYTxQueryMonad f => GYSlot -> f GYTime slotToEndTime x = flip slotToEndTimePure x <$> slotConfig {- | Get the 'GYSlot' of a 'GYTime' in 'GYTxMonad'. Returns 'Nothing' if given time is before known system start. -} -enclosingSlotFromTime :: (GYTxQueryMonad f) => GYTime -> f (Maybe GYSlot) +enclosingSlotFromTime :: GYTxQueryMonad f => GYTime -> f (Maybe GYSlot) enclosingSlotFromTime x = flip enclosingSlotFromTimePure x <$> slotConfig {- | Partial version of 'enclosingSlotFromTime'. Raises 'GYTimeUnderflowException' if given time is before known system start. -} -enclosingSlotFromTime' :: (GYTxQueryMonad m) => GYTime -> m GYSlot +enclosingSlotFromTime' :: GYTxQueryMonad m => GYTime -> m GYSlot enclosingSlotFromTime' x = do sysStart <- gyscSystemStart <$> slotConfig enclosingSlotFromTime x >>= maybe (throwError $ GYTimeUnderflowException sysStart x) pure @@ -533,13 +533,13 @@ enclosingSlotFromTime' x = do ------------------------------------------------------------------------------- -- | Calculate script's address. -scriptAddress :: (GYTxQueryMonad m) => GYValidator v -> m GYAddress +scriptAddress :: GYTxQueryMonad m => GYValidator v -> m GYAddress scriptAddress v = do nid <- networkId return $ addressFromValidator nid v -- | Calculate script's address. -scriptAddress' :: (GYTxQueryMonad m) => GYValidatorHash -> m GYAddress +scriptAddress' :: GYTxQueryMonad m => GYValidatorHash -> m GYAddress scriptAddress' h = do nid <- networkId return $ addressFromValidatorHash nid h @@ -548,18 +548,18 @@ scriptAddress' h = do Explicitly returns an error rather than throwing it. -} -addressFromPlutusM :: (GYTxQueryMonad m) => Plutus.Address -> m (Either PlutusToCardanoError GYAddress) +addressFromPlutusM :: GYTxQueryMonad m => Plutus.Address -> m (Either PlutusToCardanoError GYAddress) addressFromPlutusM addr = flip addressFromPlutus addr <$> networkId -- | 'hush'ed version of 'addressFromPlutusM'. -addressFromPlutusHushedM :: (GYTxQueryMonad m) => Plutus.Address -> m (Maybe GYAddress) +addressFromPlutusHushedM :: GYTxQueryMonad m => Plutus.Address -> m (Maybe GYAddress) addressFromPlutusHushedM addr = fmap hush $ flip addressFromPlutus addr <$> networkId {- | Convert a 'Plutus.Address' to 'GYAddress' in 'GYTxMonad'. Throw 'GYConversionException' if conversion fails. -} -addressFromPlutus' :: (GYTxQueryMonad m) => Plutus.Address -> m GYAddress +addressFromPlutus' :: GYTxQueryMonad m => Plutus.Address -> m GYAddress addressFromPlutus' addr = do x <- addressFromPlutusM addr liftEither $ first (GYConversionException . GYLedgerToCardanoError) x @@ -568,7 +568,7 @@ addressFromPlutus' addr = do Throw 'GYConversionException' if address is not key-hash one. -} -addressToPubKeyHash' :: (MonadError GYTxMonadException m) => GYAddress -> m GYPubKeyHash +addressToPubKeyHash' :: MonadError GYTxMonadException m => GYAddress -> m GYPubKeyHash addressToPubKeyHash' addr = maybe (throwError . GYConversionException $ GYNotPubKeyAddress addr) @@ -586,7 +586,7 @@ addressToPubKeyHashIO addr = Throw 'GYConversionException' if address is not script-hash one. -} -addressToValidatorHash' :: (MonadError GYTxMonadException m) => GYAddress -> m GYValidatorHash +addressToValidatorHash' :: MonadError GYTxMonadException m => GYAddress -> m GYValidatorHash addressToValidatorHash' addr = maybe (throwError . GYConversionException $ GYNotPubKeyAddress addr) @@ -604,7 +604,7 @@ addressToValidatorHashIO addr = Throw 'GYConversionException' if conversion fails. -} -valueFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.Value -> m GYValue +valueFromPlutus' :: MonadError GYTxMonadException m => Plutus.Value -> m GYValue valueFromPlutus' val = either (throwError . GYConversionException . flip GYInvalidPlutusValue val) @@ -626,7 +626,7 @@ valueFromPlutusIO val = Throw 'GYConversionException' if conversion fails. -} -makeAssetClass' :: (MonadError GYTxMonadException m) => Text -> Text -> m GYAssetClass +makeAssetClass' :: MonadError GYTxMonadException m => Text -> Text -> m GYAssetClass makeAssetClass' a b = either (throwError . GYConversionException . GYInvalidAssetClass . Txt.pack) @@ -648,7 +648,7 @@ makeAssetClassIO a b = Throw 'GYConversionException' if conversion fails. -} -assetClassFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.AssetClass -> m GYAssetClass +assetClassFromPlutus' :: MonadError GYTxMonadException m => Plutus.AssetClass -> m GYAssetClass assetClassFromPlutus' x = either (throwError . GYConversionException . GYInvalidPlutusAsset) @@ -659,7 +659,7 @@ assetClassFromPlutus' x = Throw 'GYConversionException' if conversion fails. -} -tokenNameFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.TokenName -> m GYTokenName +tokenNameFromPlutus' :: MonadError GYTxMonadException m => Plutus.TokenName -> m GYTokenName tokenNameFromPlutus' x = maybe (throwError . GYConversionException . GYInvalidPlutusAsset $ GYTokenNameTooBig x) @@ -670,7 +670,7 @@ tokenNameFromPlutus' x = Throw 'GYConversionException' if conversion fails. -} -txOutRefFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.TxOutRef -> m GYTxOutRef +txOutRefFromPlutus' :: MonadError GYTxMonadException m => Plutus.TxOutRef -> m GYTxOutRef txOutRefFromPlutus' ref = either (throwError . GYConversionException . GYLedgerToCardanoError) @@ -681,7 +681,7 @@ txOutRefFromPlutus' ref = Throw 'GYConversionException' if conversion fails. -} -datumHashFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.DatumHash -> m GYDatumHash +datumHashFromPlutus' :: MonadError GYTxMonadException m => Plutus.DatumHash -> m GYDatumHash datumHashFromPlutus' dh = either (throwError . GYConversionException . GYLedgerToCardanoError) @@ -692,7 +692,7 @@ datumHashFromPlutus' dh = Throw 'GYConversionException' if conversion fails. -} -pubKeyHashFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.PubKeyHash -> m GYPubKeyHash +pubKeyHashFromPlutus' :: MonadError GYTxMonadException m => Plutus.PubKeyHash -> m GYPubKeyHash pubKeyHashFromPlutus' pkh = either (throwError . GYConversionException . GYLedgerToCardanoError) @@ -703,7 +703,7 @@ pubKeyHashFromPlutus' pkh = Throw 'GYConversionException' if parsing fails. -} -addressFromText' :: (MonadError GYTxMonadException m) => Text -> m GYAddress +addressFromText' :: MonadError GYTxMonadException m => Text -> m GYAddress addressFromText' addr = maybe (throwError . GYConversionException $ GYInvalidAddressText addr) @@ -711,7 +711,7 @@ addressFromText' addr = (addressFromTextMaybe addr) -- | Advance 'GYSlot' forward in 'GYTxMonad'. If slot value overflows, throw 'GYSlotOverflowException'. -advanceSlot' :: (MonadError GYTxMonadException m) => GYSlot -> Natural -> m GYSlot +advanceSlot' :: MonadError GYTxMonadException m => GYSlot -> Natural -> m GYSlot advanceSlot' s t = maybe (throwError $ GYSlotOverflowException s t) @@ -722,11 +722,11 @@ utxosDatums :: forall m a. (GYTxQueryMonad m, Plutus.FromData a) => GYUTxOs -> m utxosDatums = witherUTxOs utxoDatumHushed -- | Pure variant of `utxosDatums`. -utxosDatumsPure :: (Plutus.FromData a) => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a) +utxosDatumsPure :: Plutus.FromData a => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a) utxosDatumsPure = Map.fromList . mapMaybe utxoDatumPureHushed -- | Like `utxosDatumsPure` but also returns original raw `GYDatum`. -utxosDatumsPureWithOriginalDatum :: (Plutus.FromData a) => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a, GYDatum) +utxosDatumsPureWithOriginalDatum :: Plutus.FromData a => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a, GYDatum) utxosDatumsPureWithOriginalDatum = Map.fromList . mapMaybe utxoDatumPureHushedWithOriginalDatum utxoDatum :: (GYTxQueryMonad m, Plutus.FromData a) => GYUTxO -> m (Either GYQueryDatumError (GYAddress, GYValue, a)) @@ -738,25 +738,25 @@ utxoDatum utxo = case utxoOutDatum utxo of Nothing -> pure . Left $ GYNoDatumForHash h Just d -> datumToRes d GYOutDatumInline d -> datumToRes d - where - datumToRes x = case Plutus.fromBuiltinData $ datumToPlutus' x of - Nothing -> pure . Left $ GYInvalidDatum x - Just a -> pure $ Right (utxoAddress utxo, utxoValue utxo, a) + where + datumToRes x = case Plutus.fromBuiltinData $ datumToPlutus' x of + Nothing -> pure . Left $ GYInvalidDatum x + Just a -> pure $ Right (utxoAddress utxo, utxoValue utxo, a) -- | Obtain original datum representation of an UTxO. -utxoDatumPureHushed :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a)) +utxoDatumPureHushed :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a)) utxoDatumPureHushed (_utxo, Nothing) = Nothing utxoDatumPureHushed (GYUTxO {..}, Just d) = datumToPlutus' d & Plutus.fromBuiltinData <&> \d' -> (utxoRef, (utxoAddress, utxoValue, d')) -- | Like `utxoDatumPureHushed` but also returns original raw `GYDatum`. -utxoDatumPureHushedWithOriginalDatum :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a, GYDatum)) +utxoDatumPureHushedWithOriginalDatum :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a, GYDatum)) utxoDatumPureHushedWithOriginalDatum (_utxo, Nothing) = Nothing utxoDatumPureHushedWithOriginalDatum (GYUTxO {..}, Just d) = datumToPlutus' d & Plutus.fromBuiltinData <&> \d' -> (utxoRef, (utxoAddress, utxoValue, d', d)) -- | Pure variant of `utxoDatum`. -utxoDatumPure :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a) +utxoDatumPure :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a) utxoDatumPure (utxo, Nothing) = Left $ GYNoDatumHash utxo utxoDatumPure (GYUTxO {..}, Just d) = case Plutus.fromBuiltinData $ datumToPlutus' d of @@ -764,7 +764,7 @@ utxoDatumPure (GYUTxO {..}, Just d) = Just a -> Right (utxoAddress, utxoValue, a) -- | Like `utxoDatumPure` but also returns original raw datum. -utxoDatumPureWithOriginalDatum :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a, GYDatum) +utxoDatumPureWithOriginalDatum :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a, GYDatum) utxoDatumPureWithOriginalDatum (utxo, Nothing) = Left $ GYNoDatumHash utxo utxoDatumPureWithOriginalDatum (GYUTxO {..}, Just d) = case Plutus.fromBuiltinData $ datumToPlutus' d of @@ -795,7 +795,7 @@ utxoDatumHushed = fmap hush . utxoDatum mustHaveInput :: GYTxIn v -> GYTxSkeleton v mustHaveInput i = emptyGYTxSkeleton {gytxIns = [i]} -mustHaveRefInput :: (VersionIsGreaterOrEqual v 'PlutusV2) => GYTxOutRef -> GYTxSkeleton v +mustHaveRefInput :: VersionIsGreaterOrEqual v 'PlutusV2 => GYTxOutRef -> GYTxSkeleton v mustHaveRefInput i = emptyGYTxSkeleton {gytxRefIns = GYTxSkeletonRefIns (Set.singleton i)} mustHaveOutput :: GYTxOut v -> GYTxSkeleton v @@ -817,7 +817,7 @@ mustHaveWithdrawal w = mempty {gytxWdrls = [w]} mustHaveCertificate :: GYTxCert v -> GYTxSkeleton v mustHaveCertificate c = mempty {gytxCerts = [c]} -mustBeSignedBy :: (CanSignTx a) => a -> GYTxSkeleton v +mustBeSignedBy :: CanSignTx a => a -> GYTxSkeleton v mustBeSignedBy pkh = emptyGYTxSkeleton {gytxSigs = Set.singleton $ toPubKeyHash pkh} isInvalidBefore :: GYSlot -> GYTxSkeleton v @@ -835,14 +835,14 @@ gyLogError' ns = withFrozenCallStack $ logMsg ns GYError -- | Given a skeleton, returns a list of reference to reference script UTxOs which are present as witness. skeletonToRefScriptsORefs :: GYTxSkeleton v -> [GYTxOutRef] skeletonToRefScriptsORefs GYTxSkeleton {gytxIns} = go gytxIns [] - where - go :: [GYTxIn v] -> [GYTxOutRef] -> [GYTxOutRef] - go [] acc = acc - go (gytxIn : rest) acc = case gyTxInWitness gytxIn of - GYTxInWitnessScript gyInScript _ _ -> case gyInScript of - GYInReference oRef _ -> go rest (oRef : acc) - _anyOtherMatch -> go rest acc + where + go :: [GYTxIn v] -> [GYTxOutRef] -> [GYTxOutRef] + go [] acc = acc + go (gytxIn : rest) acc = case gyTxInWitness gytxIn of + GYTxInWitnessScript gyInScript _ _ -> case gyInScript of + GYInReference oRef _ -> go rest (oRef : acc) _anyOtherMatch -> go rest acc + _anyOtherMatch -> go rest acc -- | Log the time a particular monad action took. wrapReqWithTimeLog :: (GYTxQueryMonad m, MonadIO m) => String -> m a -> m a @@ -960,22 +960,22 @@ buildTxBodyCore ownUtxoUpdateF cstrat skeletons = do case e of Left err -> throwError $ GYBuildTxException err Right res -> pure res - where - logSkeletons :: [GYTxSkeleton v] -> m () - logSkeletons = mapM_ (logMsg "buildTxBody" GYDebug . show) + where + logSkeletons :: [GYTxSkeleton v] -> m () + logSkeletons = mapM_ (logMsg "buildTxBody" GYDebug . show) -- | Update own utxo set by removing any utxos used up in the given tx. updateOwnUtxosParallel :: GYTxBody -> GYUTxOs -> GYUTxOs updateOwnUtxosParallel txBody = utxosRemoveTxOutRefs (Set.fromList txIns) - where - txIns = txBodyTxIns txBody + where + txIns = txBodyTxIns txBody {- | Update own utxo set by removing any utxos used up in the given tx, **and** adding newly created utxos addressed to own wallet. -} updateOwnUtxosChaining :: Set GYAddress -> GYTxBody -> GYUTxOs -> GYUTxOs updateOwnUtxosChaining ownAddrs txBody utxos = utxosRemoveTxOutRefs (Set.fromList txIns) utxos <> txOutsOwn - where - txIns = txBodyTxIns txBody - txOuts = txBodyUTxOs txBody - txOutsOwn = filterUTxOs (\GYUTxO {utxoAddress} -> utxoAddress `Set.member` ownAddrs) txOuts + where + txIns = txBodyTxIns txBody + txOuts = txBodyUTxOs txBody + txOutsOwn = filterUTxOs (\GYUTxO {utxoAddress} -> utxoAddress `Set.member` ownAddrs) txOuts diff --git a/src/GeniusYield/TxBuilder/Common.hs b/src/GeniusYield/TxBuilder/Common.hs index 22d19a7e..b997c7c7 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -71,10 +71,10 @@ data GYTxSkeleton (v :: PlutusVersion) = GYTxSkeleton , gytxInvalidAfter :: !(Maybe GYSlot) , gytxMetadata :: !(Maybe GYTxMetadata) } - deriving (Show) + deriving Show data GYTxSkeletonRefIns :: PlutusVersion -> Type where - GYTxSkeletonRefIns :: (VersionIsGreaterOrEqual v 'PlutusV2) => !(Set GYTxOutRef) -> GYTxSkeletonRefIns v + GYTxSkeletonRefIns :: VersionIsGreaterOrEqual v 'PlutusV2 => !(Set GYTxOutRef) -> GYTxSkeletonRefIns v GYTxSkeletonNoRefIns :: GYTxSkeletonRefIns v deriving instance Show (GYTxSkeletonRefIns v) @@ -122,23 +122,23 @@ instance Semigroup (GYTxSkeleton v) where , gytxInvalidAfter = combineInvalidAfter (gytxInvalidAfter x) (gytxInvalidAfter y) , gytxMetadata = gytxMetadata x <> gytxMetadata y } - where - -- we keep only one input per utxo to spend - combineIns u v = nubBy ((==) `on` gyTxInTxOutRef) (u ++ v) - -- we cannot combine redeemers, so we just pick first. - combineMint = Map.unionWith (\(amt, r) (amt', _r) -> (Map.unionWith (+) amt amt', r)) - -- we keep only one withdrawal per stake address - combineWdrls u v = nubBy ((==) `on` gyTxWdrlStakeAddress) (u ++ v) - - combineInvalidBefore :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot - combineInvalidBefore m Nothing = m - combineInvalidBefore Nothing n = n - combineInvalidBefore (Just s) (Just t) = Just (max s t) - - combineInvalidAfter :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot - combineInvalidAfter m Nothing = m - combineInvalidAfter Nothing n = n - combineInvalidAfter (Just s) (Just t) = Just (min s t) + where + -- we keep only one input per utxo to spend + combineIns u v = nubBy ((==) `on` gyTxInTxOutRef) (u ++ v) + -- we cannot combine redeemers, so we just pick first. + combineMint = Map.unionWith (\(amt, r) (amt', _r) -> (Map.unionWith (+) amt amt', r)) + -- we keep only one withdrawal per stake address + combineWdrls u v = nubBy ((==) `on` gyTxWdrlStakeAddress) (u ++ v) + + combineInvalidBefore :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot + combineInvalidBefore m Nothing = m + combineInvalidBefore Nothing n = n + combineInvalidBefore (Just s) (Just t) = Just (max s t) + + combineInvalidAfter :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot + combineInvalidAfter m Nothing = m + combineInvalidAfter Nothing n = n + combineInvalidAfter (Just s) (Just t) = Just (min s t) instance Monoid (GYTxSkeleton v) where mempty = emptyGYTxSkeleton @@ -238,13 +238,13 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk pure $ GYTxInDetailed gyTxIn utxoAddress utxoValue utxoOutDatum utxoRefScript else throwError $ GYDatumMismatch utxoOutDatum gyTxIn - where - checkDatumMatch _ GYTxInWitnessKey = True - checkDatumMatch _ GYTxInWitnessSimpleScript {} = True - checkDatumMatch ud (GYTxInWitnessScript _ wd _) = case ud of - GYOutDatumNone -> False - GYOutDatumHash h -> h == hashDatum wd - GYOutDatumInline uid -> uid == wd + where + checkDatumMatch _ GYTxInWitnessKey = True + checkDatumMatch _ GYTxInWitnessSimpleScript {} = True + checkDatumMatch ud (GYTxInWitnessScript _ wd _) = case ud of + GYOutDatumNone -> False + GYOutDatumHash h -> h == hashDatum wd + GYOutDatumInline uid -> uid == wd -- This operation is `O(n)` where `n` denotes the number of UTxOs in `ownUtxos'`. let totalRefScriptSize = foldl' (\acc GYUTxO {..} -> acc + maybe 0 scriptSize utxoRefScript) 0 $ refInsUtxos <> map utxoFromTxInDetailed gyTxInsDetailed @@ -298,31 +298,31 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk -- Continue with an updated accumulator (set of built results). go ownUTxos'' (updateBuildRes (Right body) acc) rest go ownUtxos GYTxBuildNoInputs skeletons - where - {- This function updates 'GYTxBuildResult' based on a build outcome - - In case of insufficient funds failure ('Left' argument): - We return either 'GYTxBuildFailure' or 'GYTxBuildPartialSuccess' - Depending on whether or not any previous transactions were built succesfully. - - In case of successful build: - We save the newly built tx body into the existing ones (if any) - - It's impossible for the second argument to ever be 'GYTxBuildFailure' or 'GYTxBuildPartialSuccess', as - the outer function 'go' (see above) always exits as soon as the accumulator updates to one of these. - -} - updateBuildRes (Left v) GYTxBuildNoInputs = GYTxBuildFailure v - updateBuildRes (Left v) (GYTxBuildSuccess ne) = GYTxBuildPartialSuccess v ne - updateBuildRes (Right x) GYTxBuildNoInputs = GYTxBuildSuccess (x :| []) - updateBuildRes (Right x) (GYTxBuildSuccess ne) = GYTxBuildSuccess (NE.cons x ne) - updateBuildRes _ _ = error "buildTxCore.flippedFoldM.updateBuildRes: absurd" - - -- TODO: Move to @Data.Sequence.NonEmpty@? - -- \| To reverse the final non-empty list built. - reverseResult :: GYTxBuildResult -> GYTxBuildResult - reverseResult (GYTxBuildSuccess ne) = GYTxBuildSuccess $ NE.reverse ne - reverseResult (GYTxBuildPartialSuccess v ne) = GYTxBuildPartialSuccess v $ NE.reverse ne - reverseResult anyOther = anyOther + where + {- This function updates 'GYTxBuildResult' based on a build outcome + + In case of insufficient funds failure ('Left' argument): + We return either 'GYTxBuildFailure' or 'GYTxBuildPartialSuccess' + Depending on whether or not any previous transactions were built succesfully. + + In case of successful build: + We save the newly built tx body into the existing ones (if any) + + It's impossible for the second argument to ever be 'GYTxBuildFailure' or 'GYTxBuildPartialSuccess', as + the outer function 'go' (see above) always exits as soon as the accumulator updates to one of these. + -} + updateBuildRes (Left v) GYTxBuildNoInputs = GYTxBuildFailure v + updateBuildRes (Left v) (GYTxBuildSuccess ne) = GYTxBuildPartialSuccess v ne + updateBuildRes (Right x) GYTxBuildNoInputs = GYTxBuildSuccess (x :| []) + updateBuildRes (Right x) (GYTxBuildSuccess ne) = GYTxBuildSuccess (NE.cons x ne) + updateBuildRes _ _ = error "buildTxCore.flippedFoldM.updateBuildRes: absurd" + + -- TODO: Move to @Data.Sequence.NonEmpty@? + -- \| To reverse the final non-empty list built. + reverseResult :: GYTxBuildResult -> GYTxBuildResult + reverseResult (GYTxBuildSuccess ne) = GYTxBuildSuccess $ NE.reverse ne + reverseResult (GYTxBuildPartialSuccess v ne) = GYTxBuildPartialSuccess v $ NE.reverse ne + reverseResult anyOther = anyOther collateralLovelace :: Integer collateralLovelace = 5_000_000 diff --git a/src/GeniusYield/TxBuilder/Errors.hs b/src/GeniusYield/TxBuilder/Errors.hs index 2055774c..4a085d48 100644 --- a/src/GeniusYield/TxBuilder/Errors.hs +++ b/src/GeniusYield/TxBuilder/Errors.hs @@ -58,7 +58,7 @@ data GYConversionError GYInvalidAssetClass !Text | -- | Errors caused by "GeniusYield.Types.Slot.slotFromInteger" resulting in 'Nothing'. GYInvalidSlot !Integer - deriving stock (Show) + deriving stock Show -- | 'GYQueryUTxOError's may be raised during utxo related queries. data GYQueryUTxOError @@ -66,7 +66,7 @@ data GYQueryUTxOError GYNoUtxosAtAddress ![GYAddress] | -- | No UTxO exists at given ref. GYNoUtxoAtRef !GYTxOutRef - deriving stock (Show) + deriving stock Show -- | 'GYQueryDatumError' may be raised during fetching and parsing datums. data GYQueryDatumError @@ -76,7 +76,7 @@ data GYQueryDatumError GYInvalidDatum !GYDatum | -- | No datum hash at utxo. GYNoDatumHash !GYUTxO - deriving stock (Show) + deriving stock Show {- | Exceptions raised within the 'GeniusYield.TxBuilder.Class.GYTxMonad' computation. diff --git a/src/GeniusYield/TxBuilder/IO/Builder.hs b/src/GeniusYield/TxBuilder/IO/Builder.hs index cfa76671..f6044a0e 100644 --- a/src/GeniusYield/TxBuilder/IO/Builder.hs +++ b/src/GeniusYield/TxBuilder/IO/Builder.hs @@ -49,7 +49,7 @@ newtype GYTxBuilderMonadIO a = GYTxBuilderMonadIO (GYTxBuilderIOEnv -> GYTxQuery , GYTxSpecialQueryMonad ) via ReaderT GYTxBuilderIOEnv GYTxQueryMonadIO - deriving anyclass (GYTxBuilderMonad) + deriving anyclass GYTxBuilderMonad data GYTxBuilderIOEnv = GYTxBuilderIOEnv { envAddrs :: ![GYAddress] @@ -82,9 +82,9 @@ instance GYTxUserQueryMonad GYTxBuilderMonadIO where usedSomeUTxOs <- getUsedSomeUTxOs utxos <- utxosAtAddresses addrs return $ utxosRemoveTxOutRefs (maybe usedSomeUTxOs ((`Set.insert` usedSomeUTxOs) . utxoRef) mCollateral) utxos - where - getCollateral = asks envCollateral - getUsedSomeUTxOs = asks envUsedSomeUTxOs + where + getCollateral = asks envCollateral + getUsedSomeUTxOs = asks envUsedSomeUTxOs someUTxO lang = do addrs <- ownAddresses @@ -96,11 +96,11 @@ instance GYTxUserQueryMonad GYTxBuilderMonadIO where case find utxoTranslatableToV1 $ utxosToList utxosToConsider of Just u -> return $ utxoRef u Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Better error message here? - where - ifNotV1 utxosToConsider addrs = - case someTxOutRef utxosToConsider of - Just (oref, _) -> return oref - Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs + where + ifNotV1 utxosToConsider addrs = + case someTxOutRef utxosToConsider of + Just (oref, _) -> return oref + Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs runGYTxBuilderMonadIO :: -- | Network ID. @@ -126,14 +126,14 @@ runGYTxBuilderMonadIO envNid envProviders envAddrs envChangeAddr collateral (GYT , envCollateral = collateral' , envUsedSomeUTxOs = mempty } - where - obtainCollateral :: IO (Maybe GYUTxO) - obtainCollateral = runMaybeT $ do - (collateralRef, toCheck) <- hoistMaybe collateral - collateralUtxo <- - liftIO $ - gyQueryUtxoAtTxOutRef envProviders collateralRef - >>= maybe (throwIO . GYQueryUTxOException $ GYNoUtxoAtRef collateralRef) pure - if not toCheck || (utxoValue collateralUtxo == collateralValue) - then return collateralUtxo - else hoistMaybe Nothing + where + obtainCollateral :: IO (Maybe GYUTxO) + obtainCollateral = runMaybeT $ do + (collateralRef, toCheck) <- hoistMaybe collateral + collateralUtxo <- + liftIO $ + gyQueryUtxoAtTxOutRef envProviders collateralRef + >>= maybe (throwIO . GYQueryUTxOException $ GYNoUtxoAtRef collateralRef) pure + if not toCheck || (utxoValue collateralUtxo == collateralValue) + then return collateralUtxo + else hoistMaybe Nothing diff --git a/src/GeniusYield/TxBuilder/Query/Class.hs b/src/GeniusYield/TxBuilder/Query/Class.hs index 589bfe2c..086b7235 100644 --- a/src/GeniusYield/TxBuilder/Query/Class.hs +++ b/src/GeniusYield/TxBuilder/Query/Class.hs @@ -31,7 +31,7 @@ import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) ------------------------------------------------------------------------------- -- | Class of monads for querying chain data. -class (MonadError GYTxMonadException m) => GYTxQueryMonad m where +class MonadError GYTxMonadException m => GYTxQueryMonad m where {-# MINIMAL networkId, lookupDatum, (utxoAtTxOutRef | utxosAtTxOutRefs), utxosAtAddress, utxosAtPaymentCredential, stakeAddressInfo, slotConfig, slotOfCurrentBlock, logMsg, waitUntilSlot, waitForNextBlock #-} -- | Get the network id @@ -70,9 +70,9 @@ class (MonadError GYTxMonadException m) => GYTxQueryMonad m where -- | Lookup 'GYUTxOs' at zero or more 'GYAddress'. utxosAtAddresses :: [GYAddress] -> m GYUTxOs utxosAtAddresses = foldM f mempty - where - f :: GYUTxOs -> GYAddress -> m GYUTxOs - f utxos addr = (<> utxos) <$> utxosAtAddress addr Nothing + where + f :: GYUTxOs -> GYAddress -> m GYUTxOs + f utxos addr = (<> utxos) <$> utxosAtAddress addr Nothing -- | Lookup UTxOs at zero or more 'GYAddress' with their datums. This has a default implementation using `utxosAtAddresses` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. utxosAtAddressesWithDatums :: [GYAddress] -> m [(GYUTxO, Maybe GYDatum)] @@ -92,9 +92,9 @@ class (MonadError GYTxMonadException m) => GYTxQueryMonad m where -- | Lookup 'GYUTxOs' at zero or more 'GYPaymentCredential'. utxosAtPaymentCredentials :: [GYPaymentCredential] -> m GYUTxOs utxosAtPaymentCredentials = foldM f mempty - where - f :: GYUTxOs -> GYPaymentCredential -> m GYUTxOs - f utxos paymentCred = (<> utxos) <$> utxosAtPaymentCredential paymentCred Nothing + where + f :: GYUTxOs -> GYPaymentCredential -> m GYUTxOs + f utxos paymentCred = (<> utxos) <$> utxosAtPaymentCredential paymentCred Nothing -- | Lookup UTxOs at zero or more 'GYPaymentCredential' with their datums. This has a default implementation using `utxosAtPaymentCredentials` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. utxosAtPaymentCredentialsWithDatums :: [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)] @@ -114,7 +114,7 @@ class (MonadError GYTxMonadException m) => GYTxQueryMonad m where slotOfCurrentBlock :: m GYSlot -- | Log a message with specified namespace and severity. - logMsg :: (HasCallStack) => GYLogNamespace -> GYLogSeverity -> String -> m () + logMsg :: HasCallStack => GYLogNamespace -> GYLogSeverity -> String -> m () -- | Wait until the chain tip is at least the given slot number, returning it's slot. waitUntilSlot :: GYSlot -> m GYSlot @@ -136,14 +136,14 @@ to decide where to draw the line regarding the interface. Our transaction buildi coin selection strategy, parallel transactions, chaining transactions etc. Should all this really be included under the class method in question? -} -class (GYTxQueryMonad m) => GYTxSpecialQueryMonad m where +class GYTxQueryMonad m => GYTxSpecialQueryMonad m where systemStart :: m Api.SystemStart eraHistory :: m Api.EraHistory protocolParams :: m ApiProtocolParameters stakePools :: m (Set Api.S.PoolId) -- | Class of monads for querying as a user. -class (GYTxQueryMonad m) => GYTxUserQueryMonad m where +class GYTxQueryMonad m => GYTxUserQueryMonad m where -- | Get your own address(es). ownAddresses :: m [GYAddress] @@ -165,7 +165,7 @@ class (GYTxQueryMonad m) => GYTxUserQueryMonad m where -- Instances for useful transformers. ------------------------------------------------------------------------------- -instance (GYTxQueryMonad m) => GYTxQueryMonad (RandT g m) where +instance GYTxQueryMonad m => GYTxQueryMonad (RandT g m) where networkId = lift networkId lookupDatum = lift . lookupDatum utxoAtTxOutRef = lift . utxoAtTxOutRef @@ -187,20 +187,20 @@ instance (GYTxQueryMonad m) => GYTxQueryMonad (RandT g m) where waitUntilSlot = lift . waitUntilSlot waitForNextBlock = lift waitForNextBlock -instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (RandT g m) where +instance GYTxUserQueryMonad m => GYTxUserQueryMonad (RandT g m) where ownAddresses = lift ownAddresses ownChangeAddress = lift ownChangeAddress ownCollateral = lift ownCollateral availableUTxOs = lift availableUTxOs someUTxO = lift . someUTxO -instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (RandT g m) where +instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (RandT g m) where systemStart = lift systemStart eraHistory = lift eraHistory protocolParams = lift protocolParams stakePools = lift stakePools -instance (GYTxQueryMonad m) => GYTxQueryMonad (ReaderT env m) where +instance GYTxQueryMonad m => GYTxQueryMonad (ReaderT env m) where networkId = lift networkId lookupDatum = lift . lookupDatum utxoAtTxOutRef = lift . utxoAtTxOutRef @@ -222,14 +222,14 @@ instance (GYTxQueryMonad m) => GYTxQueryMonad (ReaderT env m) where waitUntilSlot = lift . waitUntilSlot waitForNextBlock = lift waitForNextBlock -instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (ReaderT env m) where +instance GYTxUserQueryMonad m => GYTxUserQueryMonad (ReaderT env m) where ownAddresses = lift ownAddresses ownChangeAddress = lift ownChangeAddress ownCollateral = lift ownCollateral availableUTxOs = lift availableUTxOs someUTxO = lift . someUTxO -instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (ReaderT env m) where +instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (ReaderT env m) where systemStart = lift systemStart eraHistory = lift eraHistory protocolParams = lift protocolParams @@ -261,7 +261,7 @@ system will suffice (do NOT use free(er) monad like ones). This will trivialize entire problem. -} -instance (GYTxQueryMonad m) => GYTxQueryMonad (Strict.StateT s m) where +instance GYTxQueryMonad m => GYTxQueryMonad (Strict.StateT s m) where networkId = lift networkId lookupDatum = lift . lookupDatum utxoAtTxOutRef = lift . utxoAtTxOutRef @@ -283,20 +283,20 @@ instance (GYTxQueryMonad m) => GYTxQueryMonad (Strict.StateT s m) where waitUntilSlot = lift . waitUntilSlot waitForNextBlock = lift waitForNextBlock -instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (Strict.StateT s m) where +instance GYTxUserQueryMonad m => GYTxUserQueryMonad (Strict.StateT s m) where ownAddresses = lift ownAddresses ownChangeAddress = lift ownChangeAddress ownCollateral = lift ownCollateral availableUTxOs = lift availableUTxOs someUTxO = lift . someUTxO -instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (Strict.StateT s m) where +instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (Strict.StateT s m) where systemStart = lift systemStart eraHistory = lift eraHistory protocolParams = lift protocolParams stakePools = lift stakePools -instance (GYTxQueryMonad m) => GYTxQueryMonad (Lazy.StateT s m) where +instance GYTxQueryMonad m => GYTxQueryMonad (Lazy.StateT s m) where networkId = lift networkId lookupDatum = lift . lookupDatum utxoAtTxOutRef = lift . utxoAtTxOutRef @@ -318,14 +318,14 @@ instance (GYTxQueryMonad m) => GYTxQueryMonad (Lazy.StateT s m) where waitUntilSlot = lift . waitUntilSlot waitForNextBlock = lift waitForNextBlock -instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (Lazy.StateT s m) where +instance GYTxUserQueryMonad m => GYTxUserQueryMonad (Lazy.StateT s m) where ownAddresses = lift ownAddresses ownChangeAddress = lift ownChangeAddress ownCollateral = lift ownCollateral availableUTxOs = lift availableUTxOs someUTxO = lift . someUTxO -instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (Lazy.StateT s m) where +instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (Lazy.StateT s m) where systemStart = lift systemStart eraHistory = lift eraHistory protocolParams = lift protocolParams diff --git a/src/GeniusYield/Types/Ada.hs b/src/GeniusYield/Types/Ada.hs index 83685200..325ff436 100644 --- a/src/GeniusYield/Types/Ada.hs +++ b/src/GeniusYield/Types/Ada.hs @@ -24,7 +24,7 @@ import PlutusLedgerApi.V1.Value qualified as Value -- | Ada represented with a 'Micro' value. newtype Ada = Ada Micro deriving stock (Eq, Ord, Show) - deriving newtype (Num) + deriving newtype Num -- | Convert Ada amount to its corresponding Lovelace unit. toLovelace :: Ada -> Integer diff --git a/src/GeniusYield/Types/Address.hs b/src/GeniusYield/Types/Address.hs index d304fb19..bca9075c 100644 --- a/src/GeniusYield/Types/Address.hs +++ b/src/GeniusYield/Types/Address.hs @@ -195,9 +195,9 @@ addressToPlutus addr = case addressToApi addr of -- Lookup Ledger.Tx.CardanoAPI module in plutus-ledger. byronAddressToPlutus :: Api.S.Address Api.S.ByronAddr -> Plutus.Address byronAddressToPlutus (Api.B.ByronAddress addr) = Plutus.Address plutusCredential Nothing - where - plutusCredential :: Plutus.Credential - plutusCredential = Plutus.PubKeyCredential $ Plutus.PubKeyHash $ PlutusTx.toBuiltin $ addrToBase58 addr + where + plutusCredential :: Plutus.Credential + plutusCredential = Plutus.PubKeyCredential $ Plutus.PubKeyHash $ PlutusTx.toBuiltin $ addrToBase58 addr shelleyAddressToPlutus :: Api.Address Api.ShelleyAddr -> Plutus.Address shelleyAddressToPlutus (Api.S.ShelleyAddress _network credential stake) = @@ -231,31 +231,31 @@ addressFromPlutus nid addr = (Left $ UnknownPlutusToCardanoError $ Text.pack $ "addressFromPlutus: " <> show addr) (Right . GYAddress . Api.S.AddressShelley) $ Api.S.ShelleyAddress nid' <$> paymentCredential <*> stakeReference - where - nid' :: Ledger.Network - nid' = networkIdToLedger nid + where + nid' :: Ledger.Network + nid' = networkIdToLedger nid - credential :: Plutus.Credential -> Maybe (Ledger.Credential kr Ledger.StandardCrypto) - credential (Plutus.PubKeyCredential (Plutus.PubKeyHash (Plutus.BuiltinByteString bs))) = Ledger.KeyHashObj . Ledger.KeyHash <$> Crypto.hashFromBytes bs - credential (Plutus.ScriptCredential (Plutus.ScriptHash (Plutus.BuiltinByteString bs))) = Ledger.ScriptHashObj . Ledger.ScriptHash <$> Crypto.hashFromBytes bs + credential :: Plutus.Credential -> Maybe (Ledger.Credential kr Ledger.StandardCrypto) + credential (Plutus.PubKeyCredential (Plutus.PubKeyHash (Plutus.BuiltinByteString bs))) = Ledger.KeyHashObj . Ledger.KeyHash <$> Crypto.hashFromBytes bs + credential (Plutus.ScriptCredential (Plutus.ScriptHash (Plutus.BuiltinByteString bs))) = Ledger.ScriptHashObj . Ledger.ScriptHash <$> Crypto.hashFromBytes bs - paymentCredential :: Maybe (Ledger.PaymentCredential Ledger.StandardCrypto) - paymentCredential = credential $ Plutus.addressCredential addr + paymentCredential :: Maybe (Ledger.PaymentCredential Ledger.StandardCrypto) + paymentCredential = credential $ Plutus.addressCredential addr - stakeReference :: Maybe (Ledger.StakeReference Ledger.StandardCrypto) - stakeReference = case Plutus.addressStakingCredential addr of - Nothing -> Just Ledger.StakeRefNull - Just (Plutus.StakingHash c) -> Ledger.StakeRefBase <$> credential c - Just (Plutus.StakingPtr x y z) -> Ledger.StakeRefPtr <$> ptr x y z + stakeReference :: Maybe (Ledger.StakeReference Ledger.StandardCrypto) + stakeReference = case Plutus.addressStakingCredential addr of + Nothing -> Just Ledger.StakeRefNull + Just (Plutus.StakingHash c) -> Ledger.StakeRefBase <$> credential c + Just (Plutus.StakingPtr x y z) -> Ledger.StakeRefPtr <$> ptr x y z - ptr :: Integer -> Integer -> Integer -> Maybe Ledger.Ptr - ptr x y z = Ledger.Ptr <$> coerce integerToWord64 x <*> coerce integerToWord64 y <*> coerce integerToWord64 z + ptr :: Integer -> Integer -> Integer -> Maybe Ledger.Ptr + ptr x y z = Ledger.Ptr <$> coerce integerToWord64 x <*> coerce integerToWord64 y <*> coerce integerToWord64 z - integerToWord64 :: Integer -> Maybe Word64 - integerToWord64 n - | n < 0 = Nothing - | n > toInteger (maxBound @Word64) = Nothing - | otherwise = Just $ fromInteger n + integerToWord64 :: Integer -> Maybe Word64 + integerToWord64 n + | n < 0 = Nothing + | n > toInteger (maxBound @Word64) = Nothing + | otherwise = Just $ fromInteger n {- | If an address is a shelley address, then we'll return payment credential wrapped in `Just`, `Nothing` otherwise. @@ -370,18 +370,18 @@ addressToPubKeyHash :: GYAddress -> Maybe GYPubKeyHash addressToPubKeyHash (GYAddress (Api.AddressByron (Api.B.ByronAddress _addr))) = Nothing -- It's not clear what to do with these, and whether GY should support Byron addresses at all (as owners of pools) addressToPubKeyHash (GYAddress (Api.AddressShelley (Api.S.ShelleyAddress _network credential _stake))) = f (Api.S.fromShelleyPaymentCredential credential) - where - f :: Api.S.PaymentCredential -> Maybe GYPubKeyHash - f (Api.S.PaymentCredentialByKey h) = Just (pubKeyHashFromApi h) - f (Api.S.PaymentCredentialByScript _) = Nothing + where + f :: Api.S.PaymentCredential -> Maybe GYPubKeyHash + f (Api.S.PaymentCredentialByKey h) = Just (pubKeyHashFromApi h) + f (Api.S.PaymentCredentialByScript _) = Nothing addressToValidatorHash :: GYAddress -> Maybe GYValidatorHash addressToValidatorHash (GYAddress (Api.AddressByron _)) = Nothing addressToValidatorHash (GYAddress (Api.AddressShelley (Api.S.ShelleyAddress _network credential _stake))) = f (Api.S.fromShelleyPaymentCredential credential) - where - f :: Api.S.PaymentCredential -> Maybe GYValidatorHash - f (Api.S.PaymentCredentialByKey _) = Nothing - f (Api.S.PaymentCredentialByScript h) = Just (validatorHashFromApi h) + where + f :: Api.S.PaymentCredential -> Maybe GYValidatorHash + f (Api.S.PaymentCredentialByKey _) = Nothing + f (Api.S.PaymentCredentialByScript h) = Just (validatorHashFromApi h) ------------------------------------------------------------------------------- -- Text conversions diff --git a/src/GeniusYield/Types/Certificate.hs b/src/GeniusYield/Types/Certificate.hs index ad53cd5e..ff3f2d90 100644 --- a/src/GeniusYield/Types/Certificate.hs +++ b/src/GeniusYield/Types/Certificate.hs @@ -55,9 +55,9 @@ finaliseCert pp = \case GYStakeAddressDeregistrationCertificatePB sc -> GYStakeAddressDeregistrationCertificate ppDep' sc GYStakeAddressDelegationCertificatePB sc del -> GYStakeAddressDelegationCertificate sc del GYStakeAddressRegistrationDelegationCertificatePB sc del -> GYStakeAddressRegistrationDelegationCertificate ppDep' sc del - where - Ledger.Coin ppDep = pp ^. Ledger.ppKeyDepositL - ppDep' :: Natural = fromIntegral ppDep + where + Ledger.Coin ppDep = pp ^. Ledger.ppKeyDepositL + ppDep' :: Natural = fromIntegral ppDep certificateToApi :: GYCertificate -> Api.Certificate ApiEra certificateToApi = \case @@ -73,9 +73,9 @@ certificateToApi = \case Api.makeStakeAddressDelegationCertificate $ Api.StakeDelegationRequirementsConwayOnwards Api.ConwayEraOnwardsConway (f sc) (g del) GYStakeAddressRegistrationDelegationCertificate dep sc del -> Api.makeStakeAddressAndDRepDelegationCertificate Api.ConwayEraOnwardsConway (f sc) (g del) (fromIntegral dep) - where - f = stakeCredentialToApi - g = delegateeToLedger + where + f = stakeCredentialToApi + g = delegateeToLedger certificateFromApiMaybe :: Api.Certificate ApiEra -> Maybe GYCertificate certificateFromApiMaybe (Api.ConwayCertificate _ x) = case x of @@ -87,9 +87,9 @@ certificateFromApiMaybe (Api.ConwayCertificate _ x) = case x of Ledger.ConwayDelegCert sc del -> Just $ GYStakeAddressDelegationCertificate (f sc) (g del) Ledger.ConwayRegDelegCert sc del dep -> Just $ GYStakeAddressRegistrationDelegationCertificate (fromIntegral dep) (f sc) (g del) _ -> Nothing - where - f = stakeCredentialFromLedger - g = delegateeFromLedger + where + f = stakeCredentialFromLedger + g = delegateeFromLedger certificateFromApiMaybe _ = Nothing certificateToStakeCredential :: GYCertificate -> GYStakeCredential diff --git a/src/GeniusYield/Types/Datum.hs b/src/GeniusYield/Types/Datum.hs index a88d16d4..f3d7108b 100644 --- a/src/GeniusYield/Types/Datum.hs +++ b/src/GeniusYield/Types/Datum.hs @@ -102,7 +102,7 @@ datumFromPlutus' :: PlutusTx.BuiltinData -> GYDatum datumFromPlutus' = GYDatum -- | Get a 'GYDatum' from any Plutus 'Plutus.ToData' type. -datumFromPlutusData :: (PlutusTx.ToData a) => a -> GYDatum +datumFromPlutusData :: PlutusTx.ToData a => a -> GYDatum datumFromPlutusData = GYDatum . PlutusTx.toBuiltinData {- | Unit datum @@ -141,7 +141,7 @@ instance Aeson.ToJSON GYDatum where ------------------------------------------------------------------------------- newtype GYDatumHash = GYDatumHash (Api.Hash Api.ScriptData) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, Ord, ToJSON, FromJSON) -- >>> Web.toUrlPiece (GYDatumHash "0103c27d58a7b32241bb7f03045fae8edc01dd2f2a70a349addc17f6536fde76") diff --git a/src/GeniusYield/Types/Key.hs b/src/GeniusYield/Types/Key.hs index 6fcde731..8689e4ab 100644 --- a/src/GeniusYield/Types/Key.hs +++ b/src/GeniusYield/Types/Key.hs @@ -112,7 +112,7 @@ import GeniusYield.Types.StakeKeyHash ( GYPaymentVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" -} newtype GYPaymentVerificationKey = GYPaymentVerificationKey (Api.VerificationKey Api.PaymentKey) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, IsString) {- | @@ -185,8 +185,8 @@ instance Printf.PrintfArg GYPaymentVerificationKey where GYPaymentSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" -} newtype GYPaymentSigningKey = GYPaymentSigningKey (Api.SigningKey Api.PaymentKey) - deriving stock (Show) - deriving newtype (IsString) + deriving stock Show + deriving newtype IsString instance Eq GYPaymentSigningKey where (==) = (==) `on` show @@ -199,8 +199,8 @@ instance ToShelleyWitnessSigningKey GYPaymentSigningKey where -- Handle key for extended signing key newtype GYExtendedPaymentSigningKey = GYExtendedPaymentSigningKey (Api.SigningKey Api.PaymentExtendedKey) - deriving stock (Show) - deriving newtype (IsString) + deriving stock Show + deriving newtype IsString instance Eq GYExtendedPaymentSigningKey where (==) = (==) `on` show @@ -253,11 +253,11 @@ readPaymentSigningKey fp = do case s of Left err -> fail (show err) --- throws IOError Right x -> return (GYPaymentSigningKey x) - where - acceptedTypes = - [ Api.FromSomeType (Api.AsSigningKey Api.AsGenesisUTxOKey) Api.castSigningKey - , Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id - ] + where + acceptedTypes = + [ Api.FromSomeType (Api.AsSigningKey Api.AsGenesisUTxOKey) Api.castSigningKey + , Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id + ] -- | Reads extended payment signing key from file readExtendedPaymentSigningKey :: FilePath -> IO GYExtendedPaymentSigningKey @@ -346,7 +346,7 @@ generatePaymentSigningKey = paymentSigningKeyFromApi <$> Api.generateSigningKey GYStakeVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" -} newtype GYStakeVerificationKey = GYStakeVerificationKey (Api.VerificationKey Api.StakeKey) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, IsString) {- | @@ -413,8 +413,8 @@ instance Printf.PrintfArg GYStakeVerificationKey where GYStakeSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" -} newtype GYStakeSigningKey = GYStakeSigningKey (Api.SigningKey Api.StakeKey) - deriving stock (Show) - deriving newtype (IsString) + deriving stock Show + deriving newtype IsString instance Eq GYStakeSigningKey where (==) = (==) `on` show @@ -427,8 +427,8 @@ instance ToShelleyWitnessSigningKey GYStakeSigningKey where -- Handle key for extended signing key newtype GYExtendedStakeSigningKey = GYExtendedStakeSigningKey (Api.SigningKey Api.StakeExtendedKey) - deriving stock (Show) - deriving newtype (IsString) + deriving stock Show + deriving newtype IsString instance Eq GYExtendedStakeSigningKey where (==) = (==) `on` show diff --git a/src/GeniusYield/Types/Ledger.hs b/src/GeniusYield/Types/Ledger.hs index c9ea2329..672912f6 100644 --- a/src/GeniusYield/Types/Ledger.hs +++ b/src/GeniusYield/Types/Ledger.hs @@ -21,4 +21,4 @@ data PlutusToCardanoError StakePtrAddressUnsupported Plutus.Address | -- | Wildcard unhandled constructors; shouldn't happen usually. UnknownPlutusToCardanoError {ptceTag :: Text} - deriving stock (Show) + deriving stock Show diff --git a/src/GeniusYield/Types/Logging.hs b/src/GeniusYield/Types/Logging.hs index f823cf86..6ef25318 100644 --- a/src/GeniusYield/Types/Logging.hs +++ b/src/GeniusYield/Types/Logging.hs @@ -216,7 +216,7 @@ logContextsToKatip :: GYLogContexts -> K.LogContexts logContextsToKatip = coerce -- | Add a context to the log contexts. See `sl`. -addContext :: (KC.LogItem i) => i -> GYLogContexts -> GYLogContexts +addContext :: KC.LogItem i => i -> GYLogContexts -> GYLogContexts addContext i ctx = ctx <> logContextsFromKatip (K.liftPayload i) {- | Construct a simple log payload. @@ -224,7 +224,7 @@ addContext i ctx = ctx <> logContextsFromKatip (K.liftPayload i) >>> Aeson.encode $ logContextsToKatip $ addContext (sl "key" "value") mempty "{\"key\":\"value\"}" -} -sl :: forall a. (ToJSON a) => Text -> a -> K.SimpleLogPayload +sl :: forall a. ToJSON a => Text -> a -> K.SimpleLogPayload sl = K.sl {- | Get textual representation of log contexts. @@ -232,7 +232,7 @@ sl = K.sl >>> logContextsToS @Text $ addContext (sl "key" "value") mempty "{\"key\":\"value\"}" -} -logContextsToS :: (StringConv LBS8.ByteString a) => GYLogContexts -> a +logContextsToS :: StringConv LBS8.ByteString a => GYLogContexts -> a logContextsToS = logContextsToKatip >>> Aeson.encode >>> toS ------------------------------------------------------------------------------- @@ -279,7 +279,7 @@ data GYLogConfiguration = GYLogConfiguration cfgAddNamespace :: GYLogNamespace -> GYLogConfiguration -> GYLogConfiguration cfgAddNamespace ns cfg = cfg {cfgLogNamespace = cfgLogNamespace cfg <> ns} -cfgAddContext :: (KC.LogItem i) => i -> GYLogConfiguration -> GYLogConfiguration +cfgAddContext :: KC.LogItem i => i -> GYLogConfiguration -> GYLogConfiguration cfgAddContext i cfg = cfg {cfgLogContexts = addContext i (cfgLogContexts cfg)} logRun :: (HasCallStack, MonadIO m, StringConv a Text) => GYLogConfiguration -> GYLogSeverity -> a -> m () @@ -411,29 +411,29 @@ mkScribe GYLogScribeConfig {..} = case cfgLogType of GYCustomSourceScribe source -> do scribe <- customSourceScribe source pure (scribe, Text.pack $ show source) - where - permit :: K.PermitFunc - permit = K.permitItem $ logSeverityToKatip cfgLogSeverity - - verbosity :: K.Verbosity - verbosity = logVerbosityToKatip cfgLogVerbosity - - customSourceScribe :: LogSrc -> IO K.Scribe - customSourceScribe (LogSrc uri) = case uri of - URI {uriScheme = "", uriPath = path} -> - K.mkFileScribe path permit verbosity - URI {uriScheme = s, uriAuthority = Just URIAuth {uriRegName = domainName}} - | s `elem` ["http:", "https:"] && "sentry.io" `isSuffixOf` domainName -> - Sentry.mkSentryScribe (Sentry.sentryService $ show uri) permit verbosity - x -> - fail $ "Unsupported LogSrc: " <> show x + where + permit :: K.PermitFunc + permit = K.permitItem $ logSeverityToKatip cfgLogSeverity + + verbosity :: K.Verbosity + verbosity = logVerbosityToKatip cfgLogVerbosity + + customSourceScribe :: LogSrc -> IO K.Scribe + customSourceScribe (LogSrc uri) = case uri of + URI {uriScheme = "", uriPath = path} -> + K.mkFileScribe path permit verbosity + URI {uriScheme = s, uriAuthority = Just URIAuth {uriRegName = domainName}} + | s `elem` ["http:", "https:"] && "sentry.io" `isSuffixOf` domainName -> + Sentry.mkSentryScribe (Sentry.sentryService $ show uri) permit verbosity + x -> + fail $ "Unsupported LogSrc: " <> show x mkLogEnv :: GYLogNamespace -> [GYLogScribeConfig] -> IO GYLogEnv mkLogEnv ns cfgs = do logEnv <- K.initLogEnv (logNamespaceToKatip $ "GeniusYield" <> ns) "" logEnvFromKatip <$> foldM f logEnv cfgs - where - f :: K.LogEnv -> GYLogScribeConfig -> IO K.LogEnv - f logEnv cfg = do - (scribe, name) <- mkScribe cfg - K.registerScribe name scribe K.defaultScribeSettings logEnv + where + f :: K.LogEnv -> GYLogScribeConfig -> IO K.LogEnv + f logEnv cfg = do + (scribe, name) <- mkScribe cfg + K.registerScribe name scribe K.defaultScribeSettings logEnv diff --git a/src/GeniusYield/Types/OpenApi.hs b/src/GeniusYield/Types/OpenApi.hs index 89ef5ffd..366b602c 100644 --- a/src/GeniusYield/Types/OpenApi.hs +++ b/src/GeniusYield/Types/OpenApi.hs @@ -42,31 +42,31 @@ liftSwaggerSchema swaggerSchema = & OpenApi.enum_ .~ swaggerSchema ^. Swagger.enum_ & OpenApi.multipleOf .~ swaggerSchema ^. Swagger.multipleOf & OpenApi.items .~ (convertSwaggerItems <$> swaggerSchema ^. Swagger.items) - where - convertSwaggerItems :: Swagger.SwaggerItems Swagger.SwaggerKindSchema -> OpenApi.OpenApiItems - convertSwaggerItems (Swagger.SwaggerItemsObject s) = OpenApi.OpenApiItemsObject (convertSwaggerReferencedSchema s) - convertSwaggerItems (Swagger.SwaggerItemsArray s) = OpenApi.OpenApiItemsArray (convertSwaggerReferencedSchema <$> s) - convertSwaggerItems (Swagger.SwaggerItemsPrimitive _ _) = error "Primitive array items found in schema description, but should only be used for query params, headers and path pieces" + where + convertSwaggerItems :: Swagger.SwaggerItems Swagger.SwaggerKindSchema -> OpenApi.OpenApiItems + convertSwaggerItems (Swagger.SwaggerItemsObject s) = OpenApi.OpenApiItemsObject (convertSwaggerReferencedSchema s) + convertSwaggerItems (Swagger.SwaggerItemsArray s) = OpenApi.OpenApiItemsArray (convertSwaggerReferencedSchema <$> s) + convertSwaggerItems (Swagger.SwaggerItemsPrimitive _ _) = error "Primitive array items found in schema description, but should only be used for query params, headers and path pieces" - convertSwaggerReferencedSchema :: Swagger.Referenced Swagger.Schema -> OpenApi.Referenced OpenApi.Schema - convertSwaggerReferencedSchema (Swagger.Inline s) = OpenApi.Inline (liftSwaggerSchema s) - convertSwaggerReferencedSchema (Swagger.Ref r) = OpenApi.Ref (convertSwaggerRef r) + convertSwaggerReferencedSchema :: Swagger.Referenced Swagger.Schema -> OpenApi.Referenced OpenApi.Schema + convertSwaggerReferencedSchema (Swagger.Inline s) = OpenApi.Inline (liftSwaggerSchema s) + convertSwaggerReferencedSchema (Swagger.Ref r) = OpenApi.Ref (convertSwaggerRef r) - convertSwaggerRef :: Swagger.Reference -> OpenApi.Reference - convertSwaggerRef (Swagger.Reference ref) = OpenApi.Reference ref + convertSwaggerRef :: Swagger.Reference -> OpenApi.Reference + convertSwaggerRef (Swagger.Reference ref) = OpenApi.Reference ref - convertSwaggerType :: Swagger.SwaggerType 'Swagger.SwaggerKindSchema -> OpenApiType - convertSwaggerType Swagger.SwaggerString = OpenApiString - convertSwaggerType Swagger.SwaggerNumber = OpenApiNumber - convertSwaggerType Swagger.SwaggerInteger = OpenApiInteger - convertSwaggerType Swagger.SwaggerBoolean = OpenApiBoolean - convertSwaggerType Swagger.SwaggerArray = OpenApiArray - convertSwaggerType Swagger.SwaggerNull = OpenApiNull - convertSwaggerType Swagger.SwaggerObject = OpenApiObject + convertSwaggerType :: Swagger.SwaggerType 'Swagger.SwaggerKindSchema -> OpenApiType + convertSwaggerType Swagger.SwaggerString = OpenApiString + convertSwaggerType Swagger.SwaggerNumber = OpenApiNumber + convertSwaggerType Swagger.SwaggerInteger = OpenApiInteger + convertSwaggerType Swagger.SwaggerBoolean = OpenApiBoolean + convertSwaggerType Swagger.SwaggerArray = OpenApiArray + convertSwaggerType Swagger.SwaggerNull = OpenApiNull + convertSwaggerType Swagger.SwaggerObject = OpenApiObject - convertSwaggerAdditionalProperties :: Swagger.AdditionalProperties -> OpenApi.AdditionalProperties - convertSwaggerAdditionalProperties (Swagger.AdditionalPropertiesAllowed b) = OpenApi.AdditionalPropertiesAllowed b - convertSwaggerAdditionalProperties (Swagger.AdditionalPropertiesSchema s) = OpenApi.AdditionalPropertiesSchema (convertSwaggerReferencedSchema s) + convertSwaggerAdditionalProperties :: Swagger.AdditionalProperties -> OpenApi.AdditionalProperties + convertSwaggerAdditionalProperties (Swagger.AdditionalPropertiesAllowed b) = OpenApi.AdditionalPropertiesAllowed b + convertSwaggerAdditionalProperties (Swagger.AdditionalPropertiesSchema s) = OpenApi.AdditionalPropertiesSchema (convertSwaggerReferencedSchema s) -- | Convert a @Swagger.NamedSchema@ to an @OpenApi.NamedSchema@. convertNamedSchema :: Swagger.NamedSchema -> OpenApi.NamedSchema diff --git a/src/GeniusYield/Types/PaymentKeyHash.hs b/src/GeniusYield/Types/PaymentKeyHash.hs index 9c90da2f..cb5a96a8 100644 --- a/src/GeniusYield/Types/PaymentKeyHash.hs +++ b/src/GeniusYield/Types/PaymentKeyHash.hs @@ -48,7 +48,7 @@ import Text.Printf qualified as Printf -} newtype GYPaymentKeyHash = GYPaymentKeyHash (Api.Hash Api.PaymentKey) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, Ord, IsString) instance AsPubKeyHash GYPaymentKeyHash where @@ -80,10 +80,10 @@ e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d -} paymentKeyHashToPlutus :: GYPaymentKeyHash -> Plutus.PubKeyHash paymentKeyHashToPlutus = coerce fromCardanoPaymentKeyHash - where - -- this is not exported from plutus-ledger - fromCardanoPaymentKeyHash :: Api.Hash Api.PaymentKey -> Plutus.PubKeyHash - fromCardanoPaymentKeyHash paymentKeyHash = Plutus.PubKeyHash $ Plutus.toBuiltin $ Api.serialiseToRawBytes paymentKeyHash + where + -- this is not exported from plutus-ledger + fromCardanoPaymentKeyHash :: Api.Hash Api.PaymentKey -> Plutus.PubKeyHash + fromCardanoPaymentKeyHash paymentKeyHash = Plutus.PubKeyHash $ Plutus.toBuiltin $ Api.serialiseToRawBytes paymentKeyHash {- | diff --git a/src/GeniusYield/Types/Providers.hs b/src/GeniusYield/Types/Providers.hs index 71183b71..980bd521 100644 --- a/src/GeniusYield/Types/Providers.hs +++ b/src/GeniusYield/Types/Providers.hs @@ -263,7 +263,7 @@ data GYAwaitTxParameters = GYAwaitTxParameters , confirmations :: !Word64 -- ^ Min number of block confirmation. __NOTE:__ We might wait for more blocks than what is mentioned here but certainly not less. } - deriving stock (Show) + deriving stock Show instance Default GYAwaitTxParameters where def = @@ -274,7 +274,7 @@ instance Default GYAwaitTxParameters where } newtype GYAwaitTxException = GYAwaitTxException GYAwaitTxParameters - deriving anyclass (Exception) + deriving anyclass Exception instance Show GYAwaitTxException where show (GYAwaitTxException awaitTxParams) = @@ -299,14 +299,14 @@ gyWaitForNextBlockDefault :: IO GYSlot -> IO GYSlot gyWaitForNextBlockDefault getSlotOfCurrentBlock = do s <- getSlotOfCurrentBlock go s - where - go :: GYSlot -> IO GYSlot - go s = do - threadDelay 100_000 - t <- getSlotOfCurrentBlock - if t > s - then return t - else go s + where + go :: GYSlot -> IO GYSlot + go s = do + threadDelay 100_000 + t <- getSlotOfCurrentBlock + if t > s + then return t + else go s {- | Wait until slot. @@ -314,15 +314,15 @@ Returns the new current slot, which might be larger. -} gyWaitUntilSlotDefault :: IO GYSlot -> GYSlot -> IO GYSlot gyWaitUntilSlotDefault getSlotOfCurrentBlock s = loop - where - loop :: IO GYSlot - loop = do - t <- getSlotOfCurrentBlock - if t >= s - then return t - else do - threadDelay 100_000 - loop + where + loop :: IO GYSlot + loop = do + t <- getSlotOfCurrentBlock + if t >= s + then return t + else do + threadDelay 100_000 + loop -- | Contains the data, alongside the time after which it should be refetched. data GYSlotStore = GYSlotStore !UTCTime !GYSlot @@ -350,21 +350,21 @@ makeSlotActions t getSlotOfCurrentBlock = do , gyWaitForNextBlock' = gyWaitForNextBlockDefault gcs , gyWaitUntilSlot' = gyWaitUntilSlotDefault gcs } - where - getSlotOfCurrentBlock' :: IO UTCTime -> StrictMVar IO GYSlotStore -> IO GYSlot - getSlotOfCurrentBlock' getTime var = do - -- See note: [Caching and concurrently accessible MVars]. - modifyMVar var $ \(GYSlotStore slotRefetchTime slotData) -> do - now <- getTime - if now < slotRefetchTime - then do - -- Return unmodified. - pure (GYSlotStore slotRefetchTime slotData, slotData) - else do - newSlot <- getSlotOfCurrentBlock - newNow <- getTime - let newSlotRefetchTime = addUTCTime t newNow - pure (GYSlotStore newSlotRefetchTime newSlot, newSlot) + where + getSlotOfCurrentBlock' :: IO UTCTime -> StrictMVar IO GYSlotStore -> IO GYSlot + getSlotOfCurrentBlock' getTime var = do + -- See note: [Caching and concurrently accessible MVars]. + modifyMVar var $ \(GYSlotStore slotRefetchTime slotData) -> do + now <- getTime + if now < slotRefetchTime + then do + -- Return unmodified. + pure (GYSlotStore slotRefetchTime slotData, slotData) + else do + newSlot <- getSlotOfCurrentBlock + newNow <- getTime + let newSlotRefetchTime = addUTCTime t newNow + pure (GYSlotStore newSlotRefetchTime newSlot, newSlot) ------------------------------------------------------------------------------- -- Protocol parameters @@ -439,14 +439,14 @@ makeGetParameters getProtParams getSysStart getEraHist getStkPools = do , gyGetStakePools' = getStkPools' , gyGetSlotConfig' = getSlotConf' } - where - beforeEnd _ Nothing = True - beforeEnd currTime (Just endTime) = currTime < endTime - makeSlotConfigIO sysStart = - either - (throwIO . GYConversionException . GYEraSummariesToSlotConfigError . Txt.pack) - pure - . makeSlotConfig sysStart + where + beforeEnd _ Nothing = True + beforeEnd currTime (Just endTime) = currTime < endTime + makeSlotConfigIO sysStart = + either + (throwIO . GYConversionException . GYEraSummariesToSlotConfigError . Txt.pack) + pure + . makeSlotConfig sysStart ------------------------------------------------------------------------------- -- Query UTxO @@ -496,31 +496,31 @@ gyQueryUtxosAtTxOutRefsDefault queryUtxoAtTxOutRef orefs = do pure $ utxosFromList $ catMaybes utxos -- | Lookup UTxOs at given 'GYAddress' with their datums. This is a default implementation using `utxosAtAddress` and `lookupDatum`. -gyQueryUtxosAtAddressWithDatumsDefault :: (Monad m) => (GYAddress -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYAddress -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtAddressWithDatumsDefault :: Monad m => (GYAddress -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYAddress -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtAddressWithDatumsDefault utxosAtAddressFun lookupDatumFun addr mAssetClass = do utxosWithoutDatumResolutions <- utxosAtAddressFun addr mAssetClass utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Lookup UTxOs at zero or more 'GYAddress' with their datums. This is a default implementation using `utxosAtAddresses` and `lookupDatum`. -gyQueryUtxosAtAddressesWithDatumsDefault :: (Monad m) => ([GYAddress] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYAddress] -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtAddressesWithDatumsDefault :: Monad m => ([GYAddress] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYAddress] -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtAddressesWithDatumsDefault utxosAtAddressesFun lookupDatumFun addrs = do utxosWithoutDatumResolutions <- utxosAtAddressesFun addrs utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Lookup UTxOs at zero or more 'GYPaymentCredential' with their datums. This is a default implementation using `utxosAtPaymentCredentials` and `lookupDatum`. -gyQueryUtxosAtPaymentCredsWithDatumsDefault :: (Monad m) => ([GYPaymentCredential] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtPaymentCredsWithDatumsDefault :: Monad m => ([GYPaymentCredential] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtPaymentCredsWithDatumsDefault utxosAtPaymentCredsFun lookupDatumFun pcs = do utxosWithoutDatumResolutions <- utxosAtPaymentCredsFun pcs utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Lookup UTxOs at given 'GYPaymentCredential' with their datums. This is a default implementation using `utxosAtPaymentCredential` and `lookupDatum`. -gyQueryUtxosAtPaymentCredWithDatumsDefault :: (Monad m) => (GYPaymentCredential -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYPaymentCredential -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtPaymentCredWithDatumsDefault :: Monad m => (GYPaymentCredential -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYPaymentCredential -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtPaymentCredWithDatumsDefault utxosAtPaymentCredFun lookupDatumFun cred mAssetClass = do utxosWithoutDatumResolutions <- utxosAtPaymentCredFun cred mAssetClass utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Append UTxO information with their fetched datum. -utxosDatumResolver :: (Monad m) => GYUTxOs -> (GYDatumHash -> m (Maybe GYDatum)) -> m [(GYUTxO, Maybe GYDatum)] +utxosDatumResolver :: Monad m => GYUTxOs -> (GYDatumHash -> m (Maybe GYDatum)) -> m [(GYUTxO, Maybe GYDatum)] utxosDatumResolver utxos lookupDatumFun = do let utxosWithoutDatumResolutions = utxosToList utxos forM utxosWithoutDatumResolutions $ \utxo -> do @@ -530,7 +530,7 @@ utxosDatumResolver utxos lookupDatumFun = do GYOutDatumHash h -> (utxo,) <$> lookupDatumFun h -- | Lookup UTxOs at zero or more 'GYTxOutRef' with their datums. This is a default implementation using `utxosAtTxOutRefs` and `lookupDatum`. -gyQueryUtxosAtTxOutRefsWithDatumsDefault :: (Monad m) => ([GYTxOutRef] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYTxOutRef] -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtTxOutRefsWithDatumsDefault :: Monad m => ([GYTxOutRef] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYTxOutRef] -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtTxOutRefsWithDatumsDefault utxosAtTxOutRefsFun lookupDatumFun refs = do utxosWithoutDatumResolutions <- utxosToList <$> utxosAtTxOutRefsFun refs forM utxosWithoutDatumResolutions $ \utxo -> do diff --git a/src/GeniusYield/Types/PubKeyHash.hs b/src/GeniusYield/Types/PubKeyHash.hs index 19eb40f0..3704277a 100644 --- a/src/GeniusYield/Types/PubKeyHash.hs +++ b/src/GeniusYield/Types/PubKeyHash.hs @@ -46,14 +46,14 @@ import Text.Printf qualified as Printf -} newtype GYPubKeyHash = GYPubKeyHash (Api.Hash Api.PaymentKey) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, Ord, IsString) class AsPubKeyHash a where toPubKeyHash :: a -> GYPubKeyHash fromPubKeyHash :: GYPubKeyHash -> a -class (AsPubKeyHash a) => CanSignTx a +class AsPubKeyHash a => CanSignTx a instance AsPubKeyHash GYPubKeyHash where toPubKeyHash = id @@ -84,10 +84,10 @@ e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d -} pubKeyHashToPlutus :: GYPubKeyHash -> Plutus.PubKeyHash pubKeyHashToPlutus = coerce fromCardanoPaymentKeyHash - where - -- this is not exported from plutus-ledger - fromCardanoPaymentKeyHash :: Api.Hash Api.PaymentKey -> Plutus.PubKeyHash - fromCardanoPaymentKeyHash paymentKeyHash = Plutus.PubKeyHash $ Plutus.toBuiltin $ Api.serialiseToRawBytes paymentKeyHash + where + -- this is not exported from plutus-ledger + fromCardanoPaymentKeyHash :: Api.Hash Api.PaymentKey -> Plutus.PubKeyHash + fromCardanoPaymentKeyHash paymentKeyHash = Plutus.PubKeyHash $ Plutus.toBuiltin $ Api.serialiseToRawBytes paymentKeyHash {- | diff --git a/src/GeniusYield/Types/Redeemer.hs b/src/GeniusYield/Types/Redeemer.hs index e848eeb9..b5964436 100644 --- a/src/GeniusYield/Types/Redeemer.hs +++ b/src/GeniusYield/Types/Redeemer.hs @@ -25,7 +25,7 @@ import PlutusLedgerApi.V1 qualified as PlutusV1 import PlutusTx qualified newtype GYRedeemer = GYRedeemer PlutusTx.BuiltinData - deriving (Eq) + deriving Eq instance Show GYRedeemer where showsPrec d (GYRedeemer x) = @@ -48,7 +48,7 @@ redeemerFromPlutus (PlutusV1.Redeemer x) = GYRedeemer x redeemerFromPlutus' :: PlutusTx.BuiltinData -> GYRedeemer redeemerFromPlutus' = GYRedeemer -redeemerFromPlutusData :: (PlutusTx.ToData a) => a -> GYRedeemer +redeemerFromPlutusData :: PlutusTx.ToData a => a -> GYRedeemer redeemerFromPlutusData = GYRedeemer . PlutusTx.toBuiltinData redeemerToApi :: GYRedeemer -> Api.HashableScriptData diff --git a/src/GeniusYield/Types/Script.hs b/src/GeniusYield/Types/Script.hs index 355eb8ff..e5e7f68a 100644 --- a/src/GeniusYield/Types/Script.hs +++ b/src/GeniusYield/Types/Script.hs @@ -202,10 +202,10 @@ instance GShow GYValidator where -- FIXME: Seeing inclusion of CIP-69, we should likely get rid of all these different types of scripts and just have one type of script. -- To make it use BuiltinUnit. -validatorFromPlutus :: forall v. (SingPlutusVersionI v) => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYValidator v +validatorFromPlutus :: forall v. SingPlutusVersionI v => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYValidator v validatorFromPlutus = coerce (scriptFromPlutus @v) -validatorFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYValidator v +validatorFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYValidator v validatorFromSerialisedScript = coerce . scriptFromSerialisedScript validatorToSerialisedScript :: GYValidator v -> Plutus.SerialisedScript @@ -217,7 +217,7 @@ validatorToScript = coerce validatorToApi :: GYValidator v -> Api.PlutusScript (PlutusVersionToApi v) validatorToApi = coerce scriptToApi -validatorFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYValidator v +validatorFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYValidator v validatorFromApi = coerce (scriptFromApi @v) validatorHash :: GYValidator v -> GYValidatorHash @@ -246,7 +246,7 @@ writeValidator :: FilePath -> GYValidator v -> IO () writeValidator file = writeScriptCore "Validator" file . coerce -- | Reads a validator from a file. -readValidator :: (SingPlutusVersionI v) => FilePath -> IO (GYValidator v) +readValidator :: SingPlutusVersionI v => FilePath -> IO (GYValidator v) readValidator = coerce readScript newtype GYValidatorHash = GYValidatorHash Api.ScriptHash @@ -320,10 +320,10 @@ mintingPolicyIdFromWitness :: GYMintScript v -> GYMintingPolicyId mintingPolicyIdFromWitness (GYMintScript p) = mintingPolicyId p mintingPolicyIdFromWitness (GYMintReference _ s) = mintingPolicyId $ coerce s -mintingPolicyFromPlutus :: forall v. (SingPlutusVersionI v) => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYMintingPolicy v +mintingPolicyFromPlutus :: forall v. SingPlutusVersionI v => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYMintingPolicy v mintingPolicyFromPlutus = coerce (scriptFromPlutus @v) -mintingPolicyFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYMintingPolicy v +mintingPolicyFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYMintingPolicy v mintingPolicyFromSerialisedScript = coerce . scriptFromSerialisedScript mintingPolicyToSerialisedScript :: GYMintingPolicy v -> Plutus.SerialisedScript @@ -335,7 +335,7 @@ mintingPolicyToScript = coerce mintingPolicyToApi :: GYMintingPolicy v -> Api.PlutusScript (PlutusVersionToApi v) mintingPolicyToApi = coerce scriptToApi -mintingPolicyFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYMintingPolicy v +mintingPolicyFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYMintingPolicy v mintingPolicyFromApi = coerce (scriptFromApi @v) mintingPolicyCurrencySymbol :: GYMintingPolicy v -> PlutusV1.CurrencySymbol @@ -357,9 +357,9 @@ mintingPolicyToApiPlutusScriptWitness (GYMintingPolicy s) = data GYMintScript (u :: PlutusVersion) where -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction. - GYMintScript :: (v `VersionIsGreaterOrEqual` u) => GYMintingPolicy v -> GYMintScript u + GYMintScript :: v `VersionIsGreaterOrEqual` u => GYMintingPolicy v -> GYMintScript u -- | Reference inputs can be only used in V2 transactions. - GYMintReference :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYMintScript v + GYMintReference :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYMintScript v deriving instance Show (GYMintScript v) @@ -395,7 +395,7 @@ writeMintingPolicy :: FilePath -> GYMintingPolicy v -> IO () writeMintingPolicy file = writeScriptCore "Minting Policy" file . coerce -- | Reads a minting policy from a file. -readMintingPolicy :: (SingPlutusVersionI v) => FilePath -> IO (GYMintingPolicy v) +readMintingPolicy :: SingPlutusVersionI v => FilePath -> IO (GYMintingPolicy v) readMintingPolicy = coerce readScript -- | Minting policy identifier, also a currency symbol. @@ -422,14 +422,14 @@ instance Show GYMintingPolicyId where instance Web.FromHttpApiData GYMintingPolicyId where parseUrlPiece = first Text.pack . Atto.parseOnly parser . TE.encodeUtf8 - where - parser :: Atto.Parser GYMintingPolicyId - parser = do - cs <- Atto.takeWhile1 isHexDigit + where + parser :: Atto.Parser GYMintingPolicyId + parser = do + cs <- Atto.takeWhile1 isHexDigit - case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of - Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x - Right cs' -> return $ mintingPolicyIdFromApi cs' + case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of + Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x + Right cs' -> return $ mintingPolicyIdFromApi cs' instance Web.ToHttpApiData GYMintingPolicyId where toUrlPiece = mintingPolicyIdToText @@ -491,8 +491,8 @@ mintingPolicyIdFromText policyid = bimap customError mintingPolicyIdFromApi . Api.deserialiseFromRawBytesHex Api.S.AsPolicyId $ TE.encodeUtf8 policyid - where - customError err = "Invalid minting policy: " ++ show policyid ++ "; Reason: " ++ show err + where + customError err = "Invalid minting policy: " ++ show policyid ++ "; Reason: " ++ show err ------------------------------------------------------------------------------- -- Stake validator @@ -514,10 +514,10 @@ stakeValidatorVersionFromWitness :: GYStakeValScript v -> PlutusVersion stakeValidatorVersionFromWitness (GYStakeValScript mp) = fromSingPlutusVersion $ stakeValidatorVersion mp stakeValidatorVersionFromWitness (GYStakeValReference _ s) = fromSingPlutusVersion $ stakeValidatorVersion $ coerce s -stakeValidatorFromPlutus :: forall v. (SingPlutusVersionI v) => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYStakeValidator v +stakeValidatorFromPlutus :: forall v. SingPlutusVersionI v => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYStakeValidator v stakeValidatorFromPlutus = coerce (scriptFromPlutus @v) -stakeValidatorFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYStakeValidator v +stakeValidatorFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYStakeValidator v stakeValidatorFromSerialisedScript = coerce . scriptFromSerialisedScript stakeValidatorToSerialisedScript :: GYStakeValidator v -> Plutus.SerialisedScript @@ -529,7 +529,7 @@ stakeValidatorToScript = coerce stakeValidatorToApi :: GYStakeValidator v -> Api.PlutusScript (PlutusVersionToApi v) stakeValidatorToApi = coerce scriptToApi -stakeValidatorFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYStakeValidator v +stakeValidatorFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYStakeValidator v stakeValidatorFromApi = coerce (scriptFromApi @v) stakeValidatorToApiPlutusScriptWitness :: @@ -542,9 +542,9 @@ stakeValidatorToApiPlutusScriptWitness (GYStakeValidator s) = data GYStakeValScript (u :: PlutusVersion) where -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction. - GYStakeValScript :: (v `VersionIsGreaterOrEqual` u) => GYStakeValidator v -> GYStakeValScript u + GYStakeValScript :: v `VersionIsGreaterOrEqual` u => GYStakeValidator v -> GYStakeValScript u -- | Reference inputs can be only used in V2 transactions. - GYStakeValReference :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYStakeValScript v + GYStakeValReference :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYStakeValScript v deriving instance Show (GYStakeValScript v) @@ -633,7 +633,7 @@ writeStakeValidator :: FilePath -> GYStakeValidator v -> IO () writeStakeValidator file = writeScriptCore "Stake Validator" file . coerce -- | Reads a stake validator from a file. -readStakeValidator :: (SingPlutusVersionI v) => FilePath -> IO (GYStakeValidator v) +readStakeValidator :: SingPlutusVersionI v => FilePath -> IO (GYStakeValidator v) readStakeValidator = coerce readScript ------------------------------------------------------------------------------- @@ -687,10 +687,10 @@ instance GShow GYScript where hashScript :: GYScript v -> GYScriptHash hashScript = scriptApiHash >>> scriptHashFromApi -scriptFromPlutus :: forall v a. (SingPlutusVersionI v) => PlutusTx.CompiledCode a -> GYScript v +scriptFromPlutus :: forall v a. SingPlutusVersionI v => PlutusTx.CompiledCode a -> GYScript v scriptFromPlutus script = scriptFromApi $ Api.S.PlutusScriptSerialised $ Plutus.serialiseCompiledCode script -scriptFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYScript v +scriptFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYScript v scriptFromSerialisedScript serialisedScript = scriptFromApi $ Api.S.PlutusScriptSerialised @(PlutusVersionToApi v) serialisedScript @@ -711,8 +711,8 @@ someScriptToReferenceApi (GYPlutusScript (GYScript v apiScript _)) = Api.S.BabbageEraOnwardsConway $ Api.ScriptInAnyLang (Api.PlutusScriptLanguage v') $ Api.PlutusScript v' apiScript - where - v' = singPlutusVersionToApi v + where + v' = singPlutusVersionToApi v someScriptToReferenceApi (GYSimpleScript s) = Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway @@ -736,9 +736,9 @@ someScriptFromReferenceApi (Api.PlutusScript _ x) ) ) = Just (GYPlutusScript y) - where - y :: GYScript 'PlutusV1 - y = scriptFromApi x + where + y :: GYScript 'PlutusV1 + y = scriptFromApi x someScriptFromReferenceApi ( Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway @@ -747,9 +747,9 @@ someScriptFromReferenceApi (Api.PlutusScript _ x) ) ) = Just (GYPlutusScript y) - where - y :: GYScript 'PlutusV2 - y = scriptFromApi x + where + y :: GYScript 'PlutusV2 + y = scriptFromApi x someScriptFromReferenceApi ( Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway @@ -758,28 +758,28 @@ someScriptFromReferenceApi (Api.PlutusScript _ x) ) ) = Just (GYPlutusScript y) - where - y :: GYScript 'PlutusV3 - y = scriptFromApi x + where + y :: GYScript 'PlutusV3 + y = scriptFromApi x -scriptFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYScript v +scriptFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYScript v scriptFromApi script = GYScript v script apiHash - where - v = singPlutusVersion @v - apiScript :: Api.S.Script (PlutusVersionToApi v) - apiScript = Api.PlutusScript (singPlutusVersionToApi v) script - apiHash = Api.hashScript apiScript + where + v = singPlutusVersion @v + apiScript :: Api.S.Script (PlutusVersionToApi v) + apiScript = Api.PlutusScript (singPlutusVersionToApi v) script + apiHash = Api.hashScript apiScript -- >>> scriptFromCBOR @'PlutusV2 "59212d010000323232323322332233223232323322323232323232323332223332223232323232332232323232323232323233322232323232323233223232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323223232323223232322323253353232323232323232323232323304e3301c4912054687265616420746f6b656e206d697373696e672066726f6d20696e7075742e00330553304d301a50043035500b480094cd4c0e0030854cd4c100034854ccd400454cccccd4028418041808418441804cc140cc0792411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e005007221062106015333333500a1330503301e4911c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e00500710602106110601060221062153333335009105f13304f3301d49011c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d4914043616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f7220666972737420706c617965722773206d6f76652e0033350455052350443332001505948009402cc071401ccc075241124e4654206d757374206265206275726e742e00500621060105f105f221330513301f49011b4e6f74207369676e656420627920666972737420706c617965722e003355073301c50093355073078303d500e330513301f49110436f6d6d6974206d69736d617463682e0033036372466e28008c178004c10c03ccc144cc07d241104d697373656420646561646c696e652e003335047505433502f3039500e500d301e50095333553353332001505d001003106d1533553335001153335003106110621061153335003106110611062153335003106210611061106c106b1330513301f49011357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406d330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d24012d5365636f6e6420706c617965722773207374616b65206d697373696e6720696e2064726177206f75747075742e00330583505f301d5006303a500e13301f4901124e4654206d757374206265206275726e742e0050081330513301f4911357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406b330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d240126596f75206c6f73742c2063616e6e6f742074616b65207374616b652066726f6d2067616d652e00330583505f301d50063332001505948010c0e9403854cd4c0fc0308417c54cccccd40204178417884cc13ccc0752411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d49120466972737420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50053038500c3304f3301d4901215365636f6e6420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50043332001505748010c0e14030cc13ccc07524011357726f6e67206f757470757420646174756d2e003304f3303430415003304100d3304f3332001505a3039500335079001325335001210611061304050033304f3301d491104d697373656420646561646c696e652e003335045505233502d3037500c500a301c50073301d49011a546f6b656e206d697373696e672066726f6d206f75747075742e00330563304e301b50043036500c480084cc138cc07124011b4e6f74207369676e656420627920666972737420706c617965722e003355070301950063075303a500b3304e3301c4914143616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f72207365636f6e6420706c617965722773206d6f76652e00333504450513504333320015058480094024c06d4018cc071241124e4654206d757374206265206275726e742e005005105e22106015335303e50012100113507c4901334d6174636820726573756c7420657870656374656420627574206f757470757420646174756d20686173206e6f7468696e672e001335506e05f306f500115335335506d3355302a1200122533532323304f33033303b002303b0013304f33033303a002303a0013304f33056303800230380013304f33056303700230370013304f33056303f002303f0013304f3232350022235003225335333573466e3c0100081981944cc0e800c0044194c0dc008c0d8008cc13ccc0c8c0d4008c0d4004cc13ccc0d0c0f0008c0f0004cc13ccc158c0f4008c0f4004cc13ccc0d0c108008c108004cc0d0c10c008c10c004c0f4030c0f0cd541bc180c1c00084cd41c4008004400541c14cd4c0ac01084d400488d40048888d402c88d4008888888888888ccd54c0fc4800488d400888894cd4cc1280600104cd42280401801440154214040284c98c81f0cd5ce2481024c660007c13507a491384e6f206f7574707574206174207468697320736372697074206164647265737320686176696e672073616d6520706172616d65746572732e00221533500110022213507e49012145787065637465642065786163746c79206f6e652067616d65206f75747075742e0015335302a00321350012200113507949011347616d6520696e707574206d697373696e672e00133050330483235001222222222222008500130305006480044d400488008cccd5cd19b8735573aa00e9000119910919800801801191919191919191919191919191999ab9a3370e6aae754031200023333333333332222222222221233333333333300100d00c00b00a00900800700600500400300233502502635742a01866a04a04c6ae85402ccd409409cd5d0a805199aa814bae502835742a012666aa052eb940a0d5d0a80419a8128179aba150073335502903075a6ae854018c8c8c8cccd5cd19b8735573aa0049000119a8289919191999ab9a3370e6aae7540092000233505633503a75a6ae854008c0ecd5d09aba2500223263208f013357380c011e0211a0226aae7940044dd50009aba150023232323333573466e1cd55cea80124000466a0b066a074eb4d5d0a801181d9aba135744a004464c6411e0266ae7018023c04234044d55cf280089baa001357426ae8940088c98c822c04cd5ce02e045808448089aab9e5001137540026ae854014cd4095d71aba150043335502902c200135742a006666aa052eb88004d5d0a80118171aba135744a004464c6410e0266ae7016021c04214044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135573ca00226ea8004d5d0a803980f1aba135744a00e464c640f266ae701281e41dccccd5cd19b87500848028848888880188cccd5cd19b87500948020848888880088cccd5cd19b87500a48018848888880148cccd5cd19b87500b480108488888800c8cccd5cd19b87500c480088c8c84888888cc00402001cc134d5d09aba2500f375c6ae8540388cccd5cd19b87500d480008c84888888c01001cc134d5d09aab9e501023263207d33573809c0fa0f60f40f20f00ee0ec26664002a09e605aa00464002606aa00426664002a09c6664002a09c6058a002640026068a002640026068a002260640026666ae68cdc39aab9d500b480008cccc160c8c8c8c8c8c8c8c8c8c8c8c8cccd5cd19b8735573aa016900011999999999983218121aba1500b302435742a0146eb4d5d0a8049bad35742a0106eb4d5d0a8039919191999ab9a3370e6aae75400920002335507a375c6ae854008dd71aba135744a004464c6410a0266ae701582140420c044d55cf280089baa00135742a00c604e6ae854014dd71aba15004375a6ae85400cdd71aba15002375c6ae84d5d128011193190408099ab9c0520810107f135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226aae7940044dd50009aba1500b375c6ae854028cd4060110d5d0a80499a80c1191999ab9a3370ea0029002103111999ab9a3370ea0049001103091999ab9a3370ea0069000103191931903c99ab9c04a079077076075135573a6ea8004d5d09aba2500923263207433573808a0e80e420e626a0e292010350543500135573ca00226ea80044d55cea80109aab9e50011375400226ae8940044d5d1280089aab9e500113754002446a004444444444444a66a666aa604a24002a0484a66a666ae68cdc780700082a82a09a8370008a8368021082a882991a800911100191a80091111111111100291299a8008822899ab9c0020441232230023758002640026aa0c8446666aae7c004941688cd4164c010d5d080118019aba2002065232323333573466e1cd55cea8012400046644246600200600460166ae854008c014d5d09aba2500223263206533573806c0ca0c626aae7940044dd50009191919191999ab9a3370e6aae7540112000233332222123333001005004003002300935742a008666aa010eb9401cd5d0a8019919191999ab9a3370ea0029002119091118010021aba135573ca00646666ae68cdc3a80124004464244460020086eb8d5d09aab9e500423333573466e1d400d20002122200323263206c33573807a0d80d40d20d026aae7540044dd50009aba1500233500a75c6ae84d5d1280111931903319ab9c037066064135744a00226ae8940044d55cf280089baa0011335500175ceb44488c88c008dd5800990009aa83091191999aab9f0022505823350573355059300635573aa004600a6aae794008c010d5d100183189aba1001232323333573466e1cd55cea801240004660b060166ae854008cd4014028d5d09aba250022326320613357380640c20be26aae7940044dd500089119191999ab9a3370ea002900011a82d18029aba135573ca00646666ae68cdc3a801240044a0b4464c640c466ae700cc18818017c4d55cea80089baa001232323333573466e1d400520062321222230040053007357426aae79400c8cccd5cd19b875002480108c848888c008014c024d5d09aab9e500423333573466e1d400d20022321222230010053007357426aae7940148cccd5cd19b875004480008c848888c00c014dd71aba135573ca00c464c640c466ae700cc18818017c1781744d55cea80089baa001232323333573466e1cd55cea80124000466086600a6ae854008dd69aba135744a004464c640bc66ae700bc1781704d55cf280089baa0012323333573466e1cd55cea800a400046eb8d5d09aab9e500223263205c33573805a0b80b426ea80048c8c8c8c8c8cccd5cd19b8750014803084888888800c8cccd5cd19b875002480288488888880108cccd5cd19b875003480208cc8848888888cc004024020dd71aba15005375a6ae84d5d1280291999ab9a3370ea00890031199109111111198010048041bae35742a00e6eb8d5d09aba2500723333573466e1d40152004233221222222233006009008300c35742a0126eb8d5d09aba2500923333573466e1d40192002232122222223007008300d357426aae79402c8cccd5cd19b875007480008c848888888c014020c038d5d09aab9e500c23263206533573806c0ca0c60c40c20c00be0bc0ba26aae7540104d55cf280189aab9e5002135573ca00226ea80048c8c8c8c8cccd5cd19b875001480088ccc15cdd69aba15004375a6ae85400cdd69aba135744a00646666ae68cdc3a80124000460b260106ae84d55cf280311931902f19ab9c02f05e05c05b135573aa00626ae8940044d55cf280089baa001232323333573466e1d4005200223056375c6ae84d55cf280191999ab9a3370ea00490001182c1bae357426aae7940108c98c816ccd5ce01602d82c82c09aab9d50011375400224464646666ae68cdc3a800a40084a04a46666ae68cdc3a8012400446a04e600c6ae84d55cf280211999ab9a3370ea00690001091100111931902e19ab9c02d05c05a059058135573aa00226ea80048c8cccd5cd19b8750014800880dc8cccd5cd19b8750024800080dc8c98c8160cd5ce01482c02b02a89aab9d375400224466a03666a0386a04200406a66a03c6a04200206a640026aa0a64422444a66a00220044426600a004666aa600e2400200a00800246a002446a0044444444444446666a01a4a0b24a0b24a0b24666aa602424002a02246a00244a66a6602c00400826a0ba0062a0b801a264246600244a66a004420062002004a090640026aa0a04422444a66a00226a00644002442666a00a440046008004666aa600e2400200a00800244a66a666ae68cdc79a801110011a800910010180178999ab9a3370e6a004440026a0024400206005e205e446a004446a006446466a00a466a0084a66a666ae68cdc780100081b01a8a801881a901a919a802101a9299a999ab9a3371e00400206c06a2a006206a2a66a00642a66a0044266a004466a004466a004466a00446601a0040024070466a004407046601a00400244407044466a0084070444a66a666ae68cdc380300181d81d0a99a999ab9a3370e00a0040760742660620080022074207420662a66a00242066206644666ae68cdc780100081701691a8009111111111100291a8009111111111100311a8009111111111100411a8009111111111100491a800911100111a8009111111111100511a8009111111111100591a8009111111111100211a8009111111111100191a800911100211a8009111111111100391a800911100091a800911100191a8009111111111100111a800911111111110008919a80199a8021a80480080e99a803280400e89111a801111a801111a802911a801112999a999a8080058030010a99a8008a99a8028999a80700580180388128999a80700580180388128999a8070058018038910919800801801091091980080180109111a801111a801912999a999a8048038020010a99a8018800880f880f080f89109198008018010911191919192999a80310a999a80310a999a80410980224c26006930a999a80390980224c2600693080a08090a999a80390980224c26006930a999a80310980224c260069308098a999a80290808880908080a999a80290a999a803909802a4c26008930a999a803109802a4c2600893080988088a999a803109802a4c26008930a999a802909802a4c2600893080912999a80290a999a80390a999a80390999a8068050010008b0b0b08090a999a80310a999a80310999a8060048010008b0b0b0808880812999a80210a999a80310a999a80310999a8060048010008b0b0b08088a999a80290a999a80290999a8058040010008b0b0b0808080792999a80190a999a80290a999a80290999a8058040010008b0b0b08080a999a80210a999a80210999a8050038010008b0b0b0807880712999a80110a999a80210a999a80210999a8050038010008b0b0b08078a999a80190a999a80190999a8048030010008b0b0b08070806890911180180208911000891a80091111111003911a8009119980a00200100091299a801080088091191999ab9a3370ea0029002100c91999ab9a3370ea0049001100e11999ab9a3370ea0069000100e11931901a99ab9c006035033032031135573a6ea8005241035054310011233333333001005225335333573466e1c008004044040401854cd4ccd5cd19b890020010110101004100522333573466e2000800404404088ccd5cd19b8900200101101022333573466e2400800404004488ccd5cd19b88002001010011225335333573466e2400800404404040044008894cd4ccd5cd19b890020010110101002100112220031222002122200122333573466e1c00800403002c488cdc10010008912999a8010a999a8008805080488048a999a8008804880508048a999a80088048804880509119b8000200113222533500221533500221330050020011009153350012100910095001122533350021533350011007100610061533350011006100710061533350011006100610072333500148905506170657200488104526f636b0048810853636973736f72730012320013330020010050052223232300100532001355027223350014800088d4008894cd4ccd5cd19b8f00200900c00b130070011300600332001355026223350014800088d4008894cd4ccd5cd19b8f00200700b00a100113006003122002122001488100253353355010232323232323333333574800c46666ae68cdc39aab9d5006480008cccd55cfa8031281011999aab9f500625021233335573ea00c4a04446666aae7d40189408c8cccd55cf9aba2500725335533553355335323232323232323232323232323333333574801a46666ae68cdc39aab9d500d480008cccd55cfa8069281a11999aab9f500d25035233335573ea01a4a06c46666aae7d4034940dc8cccd55cfa8069281c11999aab9f500d25039233335573ea01a4a07446666aae7d4034940ec8cccd55cfa8069281e11999aab9f500d2503d233335573ea01a4a07c46666aae7cd5d128071299aa99aa99aa99aa99aa99aa99aa99aa99aa99aa99a98199aba150192135041302b0011503f215335303435742a032426a08460040022a0802a07e42a66a606a6ae85406084d4108c00800454100540fc854cd4c0d4d5d0a80b909a82118010008a8200a81f90a99a981a9aba1501621350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c100d5d0a80390a99a98209aba15007213504c33550480020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501521350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c8c8c8ccccccd5d200191999ab9a3370e6aae75400d2000233335573ea0064a09e46666aae7cd5d128021299a98239aba15005213505200115050250500570562504e0542504d2504d2504d2504d054135573ca00226ea8004d5d0a80390a99a981f9aba15007213504c330380020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501421350423002001150401503f215335303735742a026426a08460040022a0802a07e42a66a606a6ae85404884d4108c00800454100540fc854cd4c0dcd5d0a808909a82118010008a8200a81f90a99a981b9aba1501021350423002001150401503f2503f04604504404304204104003f03e03d03c03b2503303925032250322503225032039135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d55cf280089baa00135742a016426a04c60220022a04842a66a60386ae85402c84d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01a2502c03323333573466e1d400d2002233335573ea00a46a05c03a4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc074940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402884d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01f2502c03323333573466e1d400d2002233335573ea00a46a05c03c4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc080940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402484d409cc0080045409454090940900ac0a80a40a009c9407c094940789407894078940780944d5d1280089aba25001135744a00226aae7940044dd50008009080089a80ea491e446174756d20636f756c646e277420626520646573657269616c697365640022222222222123333333333300100c00b00a009008007006005004003002222212333300100500400300222123300100300212220031222002122200112220031222002122200123232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021280991999aab9f500425014233335573e6ae89401494cd4c02cd5d0a80390a99a99a807119191919191999999aba400623333573466e1d40092002233335573ea00c4a03e46666aae7d4018940808cccd55cfa8031281091999aab9f35744a00e4a66a602e6ae854028854cd4c060d5d0a80510a99a980c9aba1500a21350263330270030020011502415023150222502202902802702623333573466e1d400d2000233335573ea00e4a04046666aae7cd5d128041299a980b9aba150092135023302500115021250210280272501f0250242501d2501d2501d2501d024135573aa00826ae8940044d5d1280089aab9e5001137540026ae85401c84d4060cc05800800454058540549405407006c06894048060940449404494044940440604d5d1280089aab9e50011375400246666666ae900049403494034940348d4038dd68011280680a11919191999999aba400423333573466e1d40092002233335573ea0084a02246666aae7cd5d128029299a98049aba1500621350143017001150122501201901823333573466e1d400d2000233335573ea00a4a02446666aae7cd5d128031299a98051aba1500721350153019001150132501301a019250110170162500f2500f2500f2500f016135573aa00426aae7940044dd500091999999aba40012500b2500b2500b2500b23500c375c0040242446464646666666ae900108cccd5cd19b875002480008cccd55cfa8021280811999aab9f35744a00a4a66a60126ae85401884d404cd404c004540449404406005c8cccd5cd19b875003480088cccd55cfa80291a80928089280880c1280800b00a9280712807128071280700a89aab9d5002135573ca00226ea80044488c00800494ccd4d400488880084d40352411e47616d65206f757470757420646f65736e2774206861766520646174756d0021001213500e49012647616d65206f757470757420646f65736e2774206861766520646174756d20696e6c696e65640011220021221223300100400311221233001003002253353500122335002235007001250062100113500949012d4e6f205075624b65792063726564656e7469616c7320657869737420666f72207468697320616464726573732e002212330010030021212230020031122001212230020032221223330010050040032122300200321223001003123263200333573800200693090008891918008009119801980100100081" -- Just (GYScript "5a2f01c4186061b8197e6a4646d34ec8fd1f3cbdeb67fbb8ab831b25") -scriptFromCBOR :: forall v. (SingPlutusVersionI v) => Text -> Maybe (GYScript v) +scriptFromCBOR :: forall v. SingPlutusVersionI v => Text -> Maybe (GYScript v) scriptFromCBOR = scriptFromCBOR' . encodeUtf8 -- >>> scriptFromCBOR' @'PlutusV2 "59212d010000323232323322332233223232323322323232323232323332223332223232323232332232323232323232323233322232323232323233223232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323223232323223232322323253353232323232323232323232323304e3301c4912054687265616420746f6b656e206d697373696e672066726f6d20696e7075742e00330553304d301a50043035500b480094cd4c0e0030854cd4c100034854ccd400454cccccd4028418041808418441804cc140cc0792411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e005007221062106015333333500a1330503301e4911c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e00500710602106110601060221062153333335009105f13304f3301d49011c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d4914043616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f7220666972737420706c617965722773206d6f76652e0033350455052350443332001505948009402cc071401ccc075241124e4654206d757374206265206275726e742e00500621060105f105f221330513301f49011b4e6f74207369676e656420627920666972737420706c617965722e003355073301c50093355073078303d500e330513301f49110436f6d6d6974206d69736d617463682e0033036372466e28008c178004c10c03ccc144cc07d241104d697373656420646561646c696e652e003335047505433502f3039500e500d301e50095333553353332001505d001003106d1533553335001153335003106110621061153335003106110611062153335003106210611061106c106b1330513301f49011357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406d330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d24012d5365636f6e6420706c617965722773207374616b65206d697373696e6720696e2064726177206f75747075742e00330583505f301d5006303a500e13301f4901124e4654206d757374206265206275726e742e0050081330513301f4911357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406b330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d240126596f75206c6f73742c2063616e6e6f742074616b65207374616b652066726f6d2067616d652e00330583505f301d50063332001505948010c0e9403854cd4c0fc0308417c54cccccd40204178417884cc13ccc0752411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d49120466972737420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50053038500c3304f3301d4901215365636f6e6420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50043332001505748010c0e14030cc13ccc07524011357726f6e67206f757470757420646174756d2e003304f3303430415003304100d3304f3332001505a3039500335079001325335001210611061304050033304f3301d491104d697373656420646561646c696e652e003335045505233502d3037500c500a301c50073301d49011a546f6b656e206d697373696e672066726f6d206f75747075742e00330563304e301b50043036500c480084cc138cc07124011b4e6f74207369676e656420627920666972737420706c617965722e003355070301950063075303a500b3304e3301c4914143616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f72207365636f6e6420706c617965722773206d6f76652e00333504450513504333320015058480094024c06d4018cc071241124e4654206d757374206265206275726e742e005005105e22106015335303e50012100113507c4901334d6174636820726573756c7420657870656374656420627574206f757470757420646174756d20686173206e6f7468696e672e001335506e05f306f500115335335506d3355302a1200122533532323304f33033303b002303b0013304f33033303a002303a0013304f33056303800230380013304f33056303700230370013304f33056303f002303f0013304f3232350022235003225335333573466e3c0100081981944cc0e800c0044194c0dc008c0d8008cc13ccc0c8c0d4008c0d4004cc13ccc0d0c0f0008c0f0004cc13ccc158c0f4008c0f4004cc13ccc0d0c108008c108004cc0d0c10c008c10c004c0f4030c0f0cd541bc180c1c00084cd41c4008004400541c14cd4c0ac01084d400488d40048888d402c88d4008888888888888ccd54c0fc4800488d400888894cd4cc1280600104cd42280401801440154214040284c98c81f0cd5ce2481024c660007c13507a491384e6f206f7574707574206174207468697320736372697074206164647265737320686176696e672073616d6520706172616d65746572732e00221533500110022213507e49012145787065637465642065786163746c79206f6e652067616d65206f75747075742e0015335302a00321350012200113507949011347616d6520696e707574206d697373696e672e00133050330483235001222222222222008500130305006480044d400488008cccd5cd19b8735573aa00e9000119910919800801801191919191919191919191919191999ab9a3370e6aae754031200023333333333332222222222221233333333333300100d00c00b00a00900800700600500400300233502502635742a01866a04a04c6ae85402ccd409409cd5d0a805199aa814bae502835742a012666aa052eb940a0d5d0a80419a8128179aba150073335502903075a6ae854018c8c8c8cccd5cd19b8735573aa0049000119a8289919191999ab9a3370e6aae7540092000233505633503a75a6ae854008c0ecd5d09aba2500223263208f013357380c011e0211a0226aae7940044dd50009aba150023232323333573466e1cd55cea80124000466a0b066a074eb4d5d0a801181d9aba135744a004464c6411e0266ae7018023c04234044d55cf280089baa001357426ae8940088c98c822c04cd5ce02e045808448089aab9e5001137540026ae854014cd4095d71aba150043335502902c200135742a006666aa052eb88004d5d0a80118171aba135744a004464c6410e0266ae7016021c04214044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135573ca00226ea8004d5d0a803980f1aba135744a00e464c640f266ae701281e41dccccd5cd19b87500848028848888880188cccd5cd19b87500948020848888880088cccd5cd19b87500a48018848888880148cccd5cd19b87500b480108488888800c8cccd5cd19b87500c480088c8c84888888cc00402001cc134d5d09aba2500f375c6ae8540388cccd5cd19b87500d480008c84888888c01001cc134d5d09aab9e501023263207d33573809c0fa0f60f40f20f00ee0ec26664002a09e605aa00464002606aa00426664002a09c6664002a09c6058a002640026068a002640026068a002260640026666ae68cdc39aab9d500b480008cccc160c8c8c8c8c8c8c8c8c8c8c8c8cccd5cd19b8735573aa016900011999999999983218121aba1500b302435742a0146eb4d5d0a8049bad35742a0106eb4d5d0a8039919191999ab9a3370e6aae75400920002335507a375c6ae854008dd71aba135744a004464c6410a0266ae701582140420c044d55cf280089baa00135742a00c604e6ae854014dd71aba15004375a6ae85400cdd71aba15002375c6ae84d5d128011193190408099ab9c0520810107f135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226aae7940044dd50009aba1500b375c6ae854028cd4060110d5d0a80499a80c1191999ab9a3370ea0029002103111999ab9a3370ea0049001103091999ab9a3370ea0069000103191931903c99ab9c04a079077076075135573a6ea8004d5d09aba2500923263207433573808a0e80e420e626a0e292010350543500135573ca00226ea80044d55cea80109aab9e50011375400226ae8940044d5d1280089aab9e500113754002446a004444444444444a66a666aa604a24002a0484a66a666ae68cdc780700082a82a09a8370008a8368021082a882991a800911100191a80091111111111100291299a8008822899ab9c0020441232230023758002640026aa0c8446666aae7c004941688cd4164c010d5d080118019aba2002065232323333573466e1cd55cea8012400046644246600200600460166ae854008c014d5d09aba2500223263206533573806c0ca0c626aae7940044dd50009191919191999ab9a3370e6aae7540112000233332222123333001005004003002300935742a008666aa010eb9401cd5d0a8019919191999ab9a3370ea0029002119091118010021aba135573ca00646666ae68cdc3a80124004464244460020086eb8d5d09aab9e500423333573466e1d400d20002122200323263206c33573807a0d80d40d20d026aae7540044dd50009aba1500233500a75c6ae84d5d1280111931903319ab9c037066064135744a00226ae8940044d55cf280089baa0011335500175ceb44488c88c008dd5800990009aa83091191999aab9f0022505823350573355059300635573aa004600a6aae794008c010d5d100183189aba1001232323333573466e1cd55cea801240004660b060166ae854008cd4014028d5d09aba250022326320613357380640c20be26aae7940044dd500089119191999ab9a3370ea002900011a82d18029aba135573ca00646666ae68cdc3a801240044a0b4464c640c466ae700cc18818017c4d55cea80089baa001232323333573466e1d400520062321222230040053007357426aae79400c8cccd5cd19b875002480108c848888c008014c024d5d09aab9e500423333573466e1d400d20022321222230010053007357426aae7940148cccd5cd19b875004480008c848888c00c014dd71aba135573ca00c464c640c466ae700cc18818017c1781744d55cea80089baa001232323333573466e1cd55cea80124000466086600a6ae854008dd69aba135744a004464c640bc66ae700bc1781704d55cf280089baa0012323333573466e1cd55cea800a400046eb8d5d09aab9e500223263205c33573805a0b80b426ea80048c8c8c8c8c8cccd5cd19b8750014803084888888800c8cccd5cd19b875002480288488888880108cccd5cd19b875003480208cc8848888888cc004024020dd71aba15005375a6ae84d5d1280291999ab9a3370ea00890031199109111111198010048041bae35742a00e6eb8d5d09aba2500723333573466e1d40152004233221222222233006009008300c35742a0126eb8d5d09aba2500923333573466e1d40192002232122222223007008300d357426aae79402c8cccd5cd19b875007480008c848888888c014020c038d5d09aab9e500c23263206533573806c0ca0c60c40c20c00be0bc0ba26aae7540104d55cf280189aab9e5002135573ca00226ea80048c8c8c8c8cccd5cd19b875001480088ccc15cdd69aba15004375a6ae85400cdd69aba135744a00646666ae68cdc3a80124000460b260106ae84d55cf280311931902f19ab9c02f05e05c05b135573aa00626ae8940044d55cf280089baa001232323333573466e1d4005200223056375c6ae84d55cf280191999ab9a3370ea00490001182c1bae357426aae7940108c98c816ccd5ce01602d82c82c09aab9d50011375400224464646666ae68cdc3a800a40084a04a46666ae68cdc3a8012400446a04e600c6ae84d55cf280211999ab9a3370ea00690001091100111931902e19ab9c02d05c05a059058135573aa00226ea80048c8cccd5cd19b8750014800880dc8cccd5cd19b8750024800080dc8c98c8160cd5ce01482c02b02a89aab9d375400224466a03666a0386a04200406a66a03c6a04200206a640026aa0a64422444a66a00220044426600a004666aa600e2400200a00800246a002446a0044444444444446666a01a4a0b24a0b24a0b24666aa602424002a02246a00244a66a6602c00400826a0ba0062a0b801a264246600244a66a004420062002004a090640026aa0a04422444a66a00226a00644002442666a00a440046008004666aa600e2400200a00800244a66a666ae68cdc79a801110011a800910010180178999ab9a3370e6a004440026a0024400206005e205e446a004446a006446466a00a466a0084a66a666ae68cdc780100081b01a8a801881a901a919a802101a9299a999ab9a3371e00400206c06a2a006206a2a66a00642a66a0044266a004466a004466a004466a00446601a0040024070466a004407046601a00400244407044466a0084070444a66a666ae68cdc380300181d81d0a99a999ab9a3370e00a0040760742660620080022074207420662a66a00242066206644666ae68cdc780100081701691a8009111111111100291a8009111111111100311a8009111111111100411a8009111111111100491a800911100111a8009111111111100511a8009111111111100591a8009111111111100211a8009111111111100191a800911100211a8009111111111100391a800911100091a800911100191a8009111111111100111a800911111111110008919a80199a8021a80480080e99a803280400e89111a801111a801111a802911a801112999a999a8080058030010a99a8008a99a8028999a80700580180388128999a80700580180388128999a8070058018038910919800801801091091980080180109111a801111a801912999a999a8048038020010a99a8018800880f880f080f89109198008018010911191919192999a80310a999a80310a999a80410980224c26006930a999a80390980224c2600693080a08090a999a80390980224c26006930a999a80310980224c260069308098a999a80290808880908080a999a80290a999a803909802a4c26008930a999a803109802a4c2600893080988088a999a803109802a4c26008930a999a802909802a4c2600893080912999a80290a999a80390a999a80390999a8068050010008b0b0b08090a999a80310a999a80310999a8060048010008b0b0b0808880812999a80210a999a80310a999a80310999a8060048010008b0b0b08088a999a80290a999a80290999a8058040010008b0b0b0808080792999a80190a999a80290a999a80290999a8058040010008b0b0b08080a999a80210a999a80210999a8050038010008b0b0b0807880712999a80110a999a80210a999a80210999a8050038010008b0b0b08078a999a80190a999a80190999a8048030010008b0b0b08070806890911180180208911000891a80091111111003911a8009119980a00200100091299a801080088091191999ab9a3370ea0029002100c91999ab9a3370ea0049001100e11999ab9a3370ea0069000100e11931901a99ab9c006035033032031135573a6ea8005241035054310011233333333001005225335333573466e1c008004044040401854cd4ccd5cd19b890020010110101004100522333573466e2000800404404088ccd5cd19b8900200101101022333573466e2400800404004488ccd5cd19b88002001010011225335333573466e2400800404404040044008894cd4ccd5cd19b890020010110101002100112220031222002122200122333573466e1c00800403002c488cdc10010008912999a8010a999a8008805080488048a999a8008804880508048a999a80088048804880509119b8000200113222533500221533500221330050020011009153350012100910095001122533350021533350011007100610061533350011006100710061533350011006100610072333500148905506170657200488104526f636b0048810853636973736f72730012320013330020010050052223232300100532001355027223350014800088d4008894cd4ccd5cd19b8f00200900c00b130070011300600332001355026223350014800088d4008894cd4ccd5cd19b8f00200700b00a100113006003122002122001488100253353355010232323232323333333574800c46666ae68cdc39aab9d5006480008cccd55cfa8031281011999aab9f500625021233335573ea00c4a04446666aae7d40189408c8cccd55cf9aba2500725335533553355335323232323232323232323232323333333574801a46666ae68cdc39aab9d500d480008cccd55cfa8069281a11999aab9f500d25035233335573ea01a4a06c46666aae7d4034940dc8cccd55cfa8069281c11999aab9f500d25039233335573ea01a4a07446666aae7d4034940ec8cccd55cfa8069281e11999aab9f500d2503d233335573ea01a4a07c46666aae7cd5d128071299aa99aa99aa99aa99aa99aa99aa99aa99aa99aa99a98199aba150192135041302b0011503f215335303435742a032426a08460040022a0802a07e42a66a606a6ae85406084d4108c00800454100540fc854cd4c0d4d5d0a80b909a82118010008a8200a81f90a99a981a9aba1501621350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c100d5d0a80390a99a98209aba15007213504c33550480020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501521350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c8c8c8ccccccd5d200191999ab9a3370e6aae75400d2000233335573ea0064a09e46666aae7cd5d128021299a98239aba15005213505200115050250500570562504e0542504d2504d2504d2504d054135573ca00226ea8004d5d0a80390a99a981f9aba15007213504c330380020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501421350423002001150401503f215335303735742a026426a08460040022a0802a07e42a66a606a6ae85404884d4108c00800454100540fc854cd4c0dcd5d0a808909a82118010008a8200a81f90a99a981b9aba1501021350423002001150401503f2503f04604504404304204104003f03e03d03c03b2503303925032250322503225032039135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d55cf280089baa00135742a016426a04c60220022a04842a66a60386ae85402c84d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01a2502c03323333573466e1d400d2002233335573ea00a46a05c03a4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc074940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402884d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01f2502c03323333573466e1d400d2002233335573ea00a46a05c03c4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc080940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402484d409cc0080045409454090940900ac0a80a40a009c9407c094940789407894078940780944d5d1280089aba25001135744a00226aae7940044dd50008009080089a80ea491e446174756d20636f756c646e277420626520646573657269616c697365640022222222222123333333333300100c00b00a009008007006005004003002222212333300100500400300222123300100300212220031222002122200112220031222002122200123232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021280991999aab9f500425014233335573e6ae89401494cd4c02cd5d0a80390a99a99a807119191919191999999aba400623333573466e1d40092002233335573ea00c4a03e46666aae7d4018940808cccd55cfa8031281091999aab9f35744a00e4a66a602e6ae854028854cd4c060d5d0a80510a99a980c9aba1500a21350263330270030020011502415023150222502202902802702623333573466e1d400d2000233335573ea00e4a04046666aae7cd5d128041299a980b9aba150092135023302500115021250210280272501f0250242501d2501d2501d2501d024135573aa00826ae8940044d5d1280089aab9e5001137540026ae85401c84d4060cc05800800454058540549405407006c06894048060940449404494044940440604d5d1280089aab9e50011375400246666666ae900049403494034940348d4038dd68011280680a11919191999999aba400423333573466e1d40092002233335573ea0084a02246666aae7cd5d128029299a98049aba1500621350143017001150122501201901823333573466e1d400d2000233335573ea00a4a02446666aae7cd5d128031299a98051aba1500721350153019001150132501301a019250110170162500f2500f2500f2500f016135573aa00426aae7940044dd500091999999aba40012500b2500b2500b2500b23500c375c0040242446464646666666ae900108cccd5cd19b875002480008cccd55cfa8021280811999aab9f35744a00a4a66a60126ae85401884d404cd404c004540449404406005c8cccd5cd19b875003480088cccd55cfa80291a80928089280880c1280800b00a9280712807128071280700a89aab9d5002135573ca00226ea80044488c00800494ccd4d400488880084d40352411e47616d65206f757470757420646f65736e2774206861766520646174756d0021001213500e49012647616d65206f757470757420646f65736e2774206861766520646174756d20696e6c696e65640011220021221223300100400311221233001003002253353500122335002235007001250062100113500949012d4e6f205075624b65792063726564656e7469616c7320657869737420666f72207468697320616464726573732e002212330010030021212230020031122001212230020032221223330010050040032122300200321223001003123263200333573800200693090008891918008009119801980100100081" -- Just (GYScript "5a2f01c4186061b8197e6a4646d34ec8fd1f3cbdeb67fbb8ab831b25") -scriptFromCBOR' :: forall v. (SingPlutusVersionI v) => ByteString -> Maybe (GYScript v) +scriptFromCBOR' :: forall v. SingPlutusVersionI v => ByteString -> Maybe (GYScript v) scriptFromCBOR' b = do bs <- rightToMaybe (BS16.decode b) case singPlutusVersion @v of @@ -820,7 +820,7 @@ scriptToApiPlutusScriptWitness (GYScript v api _) = case v of (Api.S.PScript api) referenceScriptToApiPlutusScriptWitness :: - (VersionIsGreaterOrEqual v 'PlutusV2) => + VersionIsGreaterOrEqual v 'PlutusV2 => GYTxOutRef -> GYScript v -> Api.S.ScriptDatum witctx -> @@ -842,7 +842,7 @@ writeScript :: forall v. FilePath -> GYScript v -> IO () writeScript = writeScriptCore "Script" -- | Reads a script from a file. -readScript :: forall v. (SingPlutusVersionI v) => FilePath -> IO (GYScript v) +readScript :: forall v. SingPlutusVersionI v => FilePath -> IO (GYScript v) readScript file = case singPlutusVersion @v of SingPlutusV1 -> do e <- Api.readFileTextEnvelope (Api.AsPlutusScript Api.AsPlutusScriptV1) (Api.File file) @@ -894,12 +894,12 @@ hashAnyScript (GYPlutusScript s) = hashScript s anyScriptToApiScriptInEra :: GYAnyScript -> Api.ScriptInEra ApiEra anyScriptToApiScriptInEra (GYPlutusScript s@(GYScript v _ _)) = Api.ScriptInEra scriptInLanguageEra (scriptToApiScript s) - where - scriptInLanguageEra = case singPlutusVersionToApi v of - Api.PlutusScriptV1 -> Api.PlutusScriptV1InConway - Api.PlutusScriptV2 -> Api.PlutusScriptV2InConway - Api.PlutusScriptV3 -> Api.PlutusScriptV3InConway - - scriptToApiScript :: GYScript v -> Api.Script (PlutusVersionToApi v) - scriptToApiScript (GYScript v' api _) = Api.PlutusScript (singPlutusVersionToApi v') api + where + scriptInLanguageEra = case singPlutusVersionToApi v of + Api.PlutusScriptV1 -> Api.PlutusScriptV1InConway + Api.PlutusScriptV2 -> Api.PlutusScriptV2InConway + Api.PlutusScriptV3 -> Api.PlutusScriptV3InConway + + scriptToApiScript :: GYScript v -> Api.Script (PlutusVersionToApi v) + scriptToApiScript (GYScript v' api _) = Api.PlutusScript (singPlutusVersionToApi v') api anyScriptToApiScriptInEra (GYSimpleScript s) = Api.ScriptInEra Api.SimpleScriptInConway (Api.SimpleScript $ simpleScriptToApi s) diff --git a/src/GeniusYield/Types/Script/SimpleScript.hs b/src/GeniusYield/Types/Script/SimpleScript.hs index c70ad6d2..fcc92914 100644 --- a/src/GeniusYield/Types/Script/SimpleScript.hs +++ b/src/GeniusYield/Types/Script/SimpleScript.hs @@ -113,8 +113,8 @@ getTotalKeysInSimpleScript = \case RequireAllOf ss -> f ss RequireAnyOf ss -> f ss RequireMOf _ ss -> f ss - where - f = foldMap' getTotalKeysInSimpleScript + where + f = foldMap' getTotalKeysInSimpleScript hashSimpleScript :: GYSimpleScript -> GYScriptHash hashSimpleScript = scriptHashFromApi . hashSimpleScript' diff --git a/src/GeniusYield/Types/Slot.hs b/src/GeniusYield/Types/Slot.hs index f239baf0..c7f0fac4 100644 --- a/src/GeniusYield/Types/Slot.hs +++ b/src/GeniusYield/Types/Slot.hs @@ -63,9 +63,9 @@ advanceSlot :: GYSlot -> Natural -> Maybe GYSlot advanceSlot (GYSlot s) t | st > fromIntegral (maxBound :: Word64) = Nothing | otherwise = Just (GYSlot (fromIntegral st)) - where - st :: Natural - st = fromIntegral s + t + where + st :: Natural + st = fromIntegral s + t -- | Unsafe advance 'GYSlot'. Doesn't check for the overflow. unsafeAdvanceSlot :: GYSlot -> Natural -> GYSlot diff --git a/src/GeniusYield/Types/SlotConfig.hs b/src/GeniusYield/Types/SlotConfig.hs index a5f78695..88b82536 100644 --- a/src/GeniusYield/Types/SlotConfig.hs +++ b/src/GeniusYield/Types/SlotConfig.hs @@ -110,28 +110,28 @@ This is the recommended, robust, way to create slot config. -} makeSlotConfig :: CSlot.SystemStart -> Api.EraHistory -> Either String GYSlotConfig makeSlotConfig sysStart eraHist = GYSlotConfig sysStart <$!> simplifiedEraSumms - where - simplifiedEraSumms :: Either String (NonEmpty GYEraSlotConfig) - !simplifiedEraSumms = case extractEraSummaries eraHist of - -- This pattern match ensures the summaries start with the very first era (Bound should be all 0). - summ@(Ouroboros.Summary eraSumms@(Ouroboros.NonEmptyCons Ouroboros.EraSummary {eraStart = FirstEraBound} _)) -> - -- Verify the rest of the invariants. - runExcept (invariantSummary summ) - -- Convert the summaries into a collection of 'GYEraSlotConfig'. - $> (toEraSlotConf <$!> toNonEmpty eraSumms) - _ -> - Left $! - "Initial era element within given EraHistory must be the very first ledger era" - ++ " (Era Start bound should be 0)" - toEraSlotConf :: Ouroboros.EraSummary -> GYEraSlotConfig - toEraSlotConf - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime, boundSlot} - , eraParams = Ouroboros.EraParams {eraSlotLength} - } = GYEraSlotConfig {gyEraSlotStart = slotFromApi boundSlot, gyEraSlotLength = eraSlotLength, gyEraSlotZeroTime = boundTime} - toNonEmpty :: Ouroboros.NonEmpty xs a -> NonEmpty a - toNonEmpty (Ouroboros.NonEmptyOne x) = x :| [] - toNonEmpty (Ouroboros.NonEmptyCons x xs) = x :| toList xs + where + simplifiedEraSumms :: Either String (NonEmpty GYEraSlotConfig) + !simplifiedEraSumms = case extractEraSummaries eraHist of + -- This pattern match ensures the summaries start with the very first era (Bound should be all 0). + summ@(Ouroboros.Summary eraSumms@(Ouroboros.NonEmptyCons Ouroboros.EraSummary {eraStart = FirstEraBound} _)) -> + -- Verify the rest of the invariants. + runExcept (invariantSummary summ) + -- Convert the summaries into a collection of 'GYEraSlotConfig'. + $> (toEraSlotConf <$!> toNonEmpty eraSumms) + _ -> + Left $! + "Initial era element within given EraHistory must be the very first ledger era" + ++ " (Era Start bound should be 0)" + toEraSlotConf :: Ouroboros.EraSummary -> GYEraSlotConfig + toEraSlotConf + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime, boundSlot} + , eraParams = Ouroboros.EraParams {eraSlotLength} + } = GYEraSlotConfig {gyEraSlotStart = slotFromApi boundSlot, gyEraSlotLength = eraSlotLength, gyEraSlotZeroTime = boundTime} + toNonEmpty :: Ouroboros.NonEmpty xs a -> NonEmpty a + toNonEmpty (Ouroboros.NonEmptyOne x) = x :| [] + toNonEmpty (Ouroboros.NonEmptyCons x xs) = x :| toList xs -- The era start bound for the very first era. pattern FirstEraBound :: Ouroboros.Bound @@ -165,21 +165,21 @@ slotToBeginPOSIXTime' (GYSlotConfig sysStart slotConfs) slot = -- SystemStart + relativeResult $ CSlot.fromRelativeTime sysStart relativeResult - where - -- slotZeroTime + (slot - startSlotNo) * slotLength - relativeResult = - CSlot.getSlotLength gyEraSlotLength - `CSlot.multNominalDiffTime` (slotToInteger slot - slotToInteger gyEraSlotStart) - `CSlot.addRelativeTime` gyEraSlotZeroTime - GYEraSlotConfig {gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength} = findSlotConf slotConfs - {- Finds the slot config for the given slot. Essentially, the chosen slot config must have its starting slot - less than, or equal to, the given slot. Furthermore, the chosen slot config's end slot, i.e next slot config's - starting slot (or unbounded if final era), should be greater than the given slot. - -} - findSlotConf (x :| []) = x - findSlotConf - (thisSlotConf@GYEraSlotConfig {gyEraSlotStart = startSlot} :| nextSlotConf@GYEraSlotConfig {gyEraSlotStart = endSlot} : rest) = - if slot >= startSlot && slot < endSlot then thisSlotConf else findSlotConf $ nextSlotConf :| rest + where + -- slotZeroTime + (slot - startSlotNo) * slotLength + relativeResult = + CSlot.getSlotLength gyEraSlotLength + `CSlot.multNominalDiffTime` (slotToInteger slot - slotToInteger gyEraSlotStart) + `CSlot.addRelativeTime` gyEraSlotZeroTime + GYEraSlotConfig {gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength} = findSlotConf slotConfs + {- Finds the slot config for the given slot. Essentially, the chosen slot config must have its starting slot + less than, or equal to, the given slot. Furthermore, the chosen slot config's end slot, i.e next slot config's + starting slot (or unbounded if final era), should be greater than the given slot. + -} + findSlotConf (x :| []) = x + findSlotConf + (thisSlotConf@GYEraSlotConfig {gyEraSlotStart = startSlot} :| nextSlotConf@GYEraSlotConfig {gyEraSlotStart = endSlot} : rest) = + if slot >= startSlot && slot < endSlot then thisSlotConf else findSlotConf $ nextSlotConf :| rest {- | Get the ending 'GYTime' of a 'GYSlot' (inclusive) given a 'GYSlotConfig'. @@ -189,9 +189,9 @@ GYTime 13.999s slotToEndTimePure :: GYSlotConfig -> GYSlot -> GYTime slotToEndTimePure sc@(GYSlotConfig _ _) slot = timeFromPOSIX $ slotToBeginPOSIXTime' sc (unsafeAdvanceSlot slot 1) - oneMs - where - oneMs :: Time.NominalDiffTime - oneMs = 0.001 + where + oneMs :: Time.NominalDiffTime + oneMs = 0.001 {- | Get the 'GYSlot' of a 'GYTime' given a 'GYSlotConfig'. @@ -209,24 +209,24 @@ enclosingSlotFromTimePure (GYSlotConfig sysStart slotConfs) (timeToPOSIX -> absT | otherwise = -- startSlotNo + relativeResult Just . slotFromApi . Ouroboros.addSlots relativeResult $ slotToApi gyEraSlotStart - where - absTimeUtc = Time.posixSecondsToUTCTime absTime - -- absTime - SystemStart - relTime = CSlot.toRelativeTime sysStart absTimeUtc - -- (relTime - slotZeroTime) / slotLength - relativeResult = (relTime `CSlot.diffRelativeTime` gyEraSlotZeroTime) `div'` CSlot.getSlotLength gyEraSlotLength - GYEraSlotConfig {gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength} = findSlotConf slotConfs - {- Finds the slot config for the given relative time. Essentially, the chosen slot config must have its starting time - greater than, or equal to, the given relative time. Furthermore, the chosen slot config's end time, i.e next slot config's - starting time (or unbounded if final era), should be greater than the given relative time. - -} - findSlotConf (x :| []) = x - findSlotConf - ( thisSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = startTime} - :| nextSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = endTime} - : rest - ) = - if relTime >= startTime && relTime < endTime then thisSlotConf else findSlotConf $ nextSlotConf :| rest + where + absTimeUtc = Time.posixSecondsToUTCTime absTime + -- absTime - SystemStart + relTime = CSlot.toRelativeTime sysStart absTimeUtc + -- (relTime - slotZeroTime) / slotLength + relativeResult = (relTime `CSlot.diffRelativeTime` gyEraSlotZeroTime) `div'` CSlot.getSlotLength gyEraSlotLength + GYEraSlotConfig {gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength} = findSlotConf slotConfs + {- Finds the slot config for the given relative time. Essentially, the chosen slot config must have its starting time + greater than, or equal to, the given relative time. Furthermore, the chosen slot config's end time, i.e next slot config's + starting time (or unbounded if final era), should be greater than the given relative time. + -} + findSlotConf (x :| []) = x + findSlotConf + ( thisSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = startTime} + :| nextSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = endTime} + : rest + ) = + if relTime >= startTime && relTime < endTime then thisSlotConf else findSlotConf $ nextSlotConf :| rest -- | Partial version of 'enclosingSlotFromTimePure'. unsafeEnclosingSlotFromTimePure :: GYSlotConfig -> GYTime -> GYSlot @@ -249,66 +249,66 @@ invariantSummary :: Ouroboros.Summary xs -> Except String () invariantSummary = \(Ouroboros.Summary summary) -> -- Pretend the start of the first era is the "end of the previous" one go (Ouroboros.eraStart (Ouroboros.nonEmptyHead summary)) (toList summary) - where - go :: - Ouroboros.Bound -> - -- \^ End of the previous era - [Ouroboros.EraSummary] -> - Except String () - go _ [] = return () - go prevEnd (curSummary : next) = do - unless (curStart == prevEnd) $ - throwError $ - mconcat - [ "Bounds don't line up: end of previous era " - , show prevEnd - , " /= start of current era " - , show curStart - ] - - case mCurEnd of - Ouroboros.EraUnbounded -> - unless (null next) $ - throwError "Unbounded non-final era" - Ouroboros.EraEnd curEnd -> do - -- Check the invariants mentioned at 'EraSummary' - -- - -- o @epochsInEra@ corresponds to @e' - e@ - -- o @slotsInEra@ corresponds to @(e' - e) * epochSize)@ - -- o @timeInEra@ corresponds to @((e' - e) * epochSize * slotLen@ - -- which, if INV-1b holds, equals @(s' - s) * slotLen@ - let epochsInEra, slotsInEra :: Word64 - epochsInEra = Ouroboros.countEpochs (Ouroboros.boundEpoch curEnd) (Ouroboros.boundEpoch curStart) - slotsInEra = epochsInEra * CSlot.unEpochSize (Ouroboros.eraEpochSize curParams) - - timeInEra :: NominalDiffTime - timeInEra = - fromIntegral slotsInEra - * CSlot.getSlotLength (Ouroboros.eraSlotLength curParams) - - -- NOTE: The only change is here, using >= rather than > - unless (Ouroboros.boundEpoch curEnd >= Ouroboros.boundEpoch curStart) $ - throwError "Empty era" - - unless (Ouroboros.boundSlot curEnd == Ouroboros.addSlots slotsInEra (Ouroboros.boundSlot curStart)) $ - throwError $ - mconcat - [ "Invalid final boundSlot in " - , show curSummary - , " (INV-1b)" - ] - - unless (Ouroboros.boundTime curEnd == Ouroboros.addRelTime timeInEra (Ouroboros.boundTime curStart)) $ - throwError $ - mconcat - [ "Invalid final boundTime in " - , show curSummary - , " (INV-2b)" - ] - - go curEnd next - where - curStart :: Ouroboros.Bound - mCurEnd :: Ouroboros.EraEnd - curParams :: Ouroboros.EraParams - Ouroboros.EraSummary curStart mCurEnd curParams = curSummary + where + go :: + Ouroboros.Bound -> + -- \^ End of the previous era + [Ouroboros.EraSummary] -> + Except String () + go _ [] = return () + go prevEnd (curSummary : next) = do + unless (curStart == prevEnd) $ + throwError $ + mconcat + [ "Bounds don't line up: end of previous era " + , show prevEnd + , " /= start of current era " + , show curStart + ] + + case mCurEnd of + Ouroboros.EraUnbounded -> + unless (null next) $ + throwError "Unbounded non-final era" + Ouroboros.EraEnd curEnd -> do + -- Check the invariants mentioned at 'EraSummary' + -- + -- o @epochsInEra@ corresponds to @e' - e@ + -- o @slotsInEra@ corresponds to @(e' - e) * epochSize)@ + -- o @timeInEra@ corresponds to @((e' - e) * epochSize * slotLen@ + -- which, if INV-1b holds, equals @(s' - s) * slotLen@ + let epochsInEra, slotsInEra :: Word64 + epochsInEra = Ouroboros.countEpochs (Ouroboros.boundEpoch curEnd) (Ouroboros.boundEpoch curStart) + slotsInEra = epochsInEra * CSlot.unEpochSize (Ouroboros.eraEpochSize curParams) + + timeInEra :: NominalDiffTime + timeInEra = + fromIntegral slotsInEra + * CSlot.getSlotLength (Ouroboros.eraSlotLength curParams) + + -- NOTE: The only change is here, using >= rather than > + unless (Ouroboros.boundEpoch curEnd >= Ouroboros.boundEpoch curStart) $ + throwError "Empty era" + + unless (Ouroboros.boundSlot curEnd == Ouroboros.addSlots slotsInEra (Ouroboros.boundSlot curStart)) $ + throwError $ + mconcat + [ "Invalid final boundSlot in " + , show curSummary + , " (INV-1b)" + ] + + unless (Ouroboros.boundTime curEnd == Ouroboros.addRelTime timeInEra (Ouroboros.boundTime curStart)) $ + throwError $ + mconcat + [ "Invalid final boundTime in " + , show curSummary + , " (INV-2b)" + ] + + go curEnd next + where + curStart :: Ouroboros.Bound + mCurEnd :: Ouroboros.EraEnd + curParams :: Ouroboros.EraParams + Ouroboros.EraSummary curStart mCurEnd curParams = curSummary diff --git a/src/GeniusYield/Types/StakeKeyHash.hs b/src/GeniusYield/Types/StakeKeyHash.hs index 0a4cafd2..e6259674 100644 --- a/src/GeniusYield/Types/StakeKeyHash.hs +++ b/src/GeniusYield/Types/StakeKeyHash.hs @@ -43,7 +43,7 @@ import Text.Printf qualified as Printf -} newtype GYStakeKeyHash = GYStakeKeyHash (Api.Hash Api.StakeKey) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, Ord, IsString) instance AsPubKeyHash GYStakeKeyHash where diff --git a/src/GeniusYield/Types/Time.hs b/src/GeniusYield/Types/Time.hs index 1169c776..695b8f2d 100644 --- a/src/GeniusYield/Types/Time.hs +++ b/src/GeniusYield/Types/Time.hs @@ -162,7 +162,7 @@ Just (GYTime 33.333s) >>> gyIso8601ParseM @Maybe "1970-01-01T00:00:33.333" Nothing -} -gyIso8601ParseM :: (MonadFail m) => String -> m GYTime +gyIso8601ParseM :: MonadFail m => String -> m GYTime gyIso8601ParseM = fmap (GYTime . Time.utcTimeToPOSIXSeconds) . Time.iso8601ParseM {- | diff --git a/src/GeniusYield/Types/Tx.hs b/src/GeniusYield/Types/Tx.hs index fc739420..83e4f0b6 100644 --- a/src/GeniusYield/Types/Tx.hs +++ b/src/GeniusYield/Types/Tx.hs @@ -187,13 +187,13 @@ writeTx file tx = do Right () -> pure () data PlutusTxId (v :: PlutusVersion) where - PlutusTxIdBeforeV3 :: (PlutusV3 `VersionIsGreater` v) => PlutusV1.TxId -> PlutusTxId v + PlutusTxIdBeforeV3 :: PlutusV3 `VersionIsGreater` v => PlutusV1.TxId -> PlutusTxId v PlutusTxIdV3 :: PlutusV3.TxId -> PlutusTxId 'PlutusV3 -- | Transaction hash/id of a particular transaction. newtype GYTxId = GYTxId Api.TxId deriving (Eq, Ord) - deriving newtype (FromJSON) -- TODO: Also derive ToJSON? + deriving newtype FromJSON -- TODO: Also derive ToJSON? instance PQ.ToField GYTxId where toField (GYTxId txId) = PQ.toField (PQ.Binary (Api.serialiseToRawBytes txId)) @@ -278,7 +278,7 @@ txIdFromPlutus (PlutusTxIdV3 (PlutusV3.TxId (Plutus.BuiltinByteString bs))) = tx -- | Wrapper around transaction witness set. Note that Babbage ledger also uses the same @TxWitness@ type defined in Alonzo ledger, which was updated for Plutus-V2 scripts and same is expected for Plutus-V3. newtype GYTxWitness = GYTxWitness (AlonzoTxWits (Conway.ConwayEra Crypto.StandardCrypto)) - deriving newtype (Show) + deriving newtype Show instance Swagger.ToSchema GYTxWitness where declareNamedSchema _ = diff --git a/src/GeniusYield/Types/TxBody.hs b/src/GeniusYield/Types/TxBody.hs index 61bc8313..6eed7d14 100644 --- a/src/GeniusYield/Types/TxBody.hs +++ b/src/GeniusYield/Types/TxBody.hs @@ -71,7 +71,7 @@ import GeniusYield.Types.Value -- | Transaction body: the part which is then signed. newtype GYTxBody = GYTxBody (Api.TxBody ApiEra) - deriving (Show) + deriving Show txBodyFromApi :: Api.TxBody ApiEra -> GYTxBody txBodyFromApi = coerce @@ -80,11 +80,11 @@ txBodyToApi :: GYTxBody -> Api.TxBody ApiEra txBodyToApi = coerce -- | Sign a transaction body with (potentially) multiple keys. -signGYTxBody :: (ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> GYTx +signGYTxBody :: ToShelleyWitnessSigningKey a => GYTxBody -> [a] -> GYTx signGYTxBody = signTx {-# DEPRECATED signTx "Use signGYTxBody." #-} -signTx :: (ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> GYTx +signTx :: ToShelleyWitnessSigningKey a => GYTxBody -> [a] -> GYTx signTx (GYTxBody txBody) skeys = txFromApi $ Api.signShelleyTransaction @@ -120,7 +120,7 @@ appendWitnessGYTx' appendKeyWitnessList previousTx = in makeSignedTransaction' (previousKeyWitnessesList ++ appendKeyWitnessList) txBody -- | Sign a transaction with (potentially) multiple keys and add your witness(s) among previous key witnesses, if any. -signGYTx :: (ToShelleyWitnessSigningKey a) => GYTx -> [a] -> GYTx +signGYTx :: ToShelleyWitnessSigningKey a => GYTx -> [a] -> GYTx signGYTx previousTx skeys = signGYTx'' previousTx $ map toShelleyWitnessSigningKey skeys -- | Sign a transaction with (potentially) multiple keys and add your witness(s) among previous key witnesses, if any. @@ -179,11 +179,11 @@ txBodyFeeValue = valueFromLovelace . txBodyFee txBodyUTxOs :: GYTxBody -> GYUTxOs txBodyUTxOs (GYTxBody body@(Api.TxBody Api.TxBodyContent {txOuts})) = utxosFromList $ zipWith f [0 ..] txOuts - where - txId = Api.getTxId body + where + txId = Api.getTxId body - f :: Word -> Api.TxOut Api.CtxTx ApiEra -> GYUTxO - f i = utxoFromApi (Api.TxIn txId (Api.TxIx i)) + f :: Word -> Api.TxOut Api.CtxTx ApiEra -> GYUTxO + f i = utxoFromApi (Api.TxIn txId (Api.TxIx i)) -- | Returns the 'GYTxOutRef' consumed by the tx. txBodyTxIns :: GYTxBody -> [GYTxOutRef] @@ -224,14 +224,14 @@ txBodyValidityRange body = let cnt = txBodyToApiTxBodyContent body in case (Api.txValidityLowerBound cnt, Api.txValidityUpperBound cnt) of (lb, ub) -> (f lb, g ub) - where - f :: Api.TxValidityLowerBound ApiEra -> Maybe GYSlot - f Api.TxValidityNoLowerBound = Nothing - f (Api.TxValidityLowerBound _ sn) = Just $ slotFromApi sn - - g :: Api.TxValidityUpperBound ApiEra -> Maybe GYSlot - g (Api.TxValidityUpperBound _ Nothing) = Nothing - g (Api.TxValidityUpperBound _ (Just sn)) = Just $ slotFromApi sn + where + f :: Api.TxValidityLowerBound ApiEra -> Maybe GYSlot + f Api.TxValidityNoLowerBound = Nothing + f (Api.TxValidityLowerBound _ sn) = Just $ slotFromApi sn + + g :: Api.TxValidityUpperBound ApiEra -> Maybe GYSlot + g (Api.TxValidityUpperBound _ Nothing) = Nothing + g (Api.TxValidityUpperBound _ (Just sn)) = Just $ slotFromApi sn -- | Returns the set of 'GYTxOutRef' used as collateral in the given 'GYTxBody'. txBodyCollateral :: GYTxBody -> Set GYTxOutRef diff --git a/src/GeniusYield/Types/TxCert/Internal.hs b/src/GeniusYield/Types/TxCert/Internal.hs index 3e8b0205..296cf732 100644 --- a/src/GeniusYield/Types/TxCert/Internal.hs +++ b/src/GeniusYield/Types/TxCert/Internal.hs @@ -57,12 +57,12 @@ txCertToApi :: GYTxCert' v -> (Api.Certificate ApiEra, Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake ApiEra)) txCertToApi (GYTxCert' cert wit) = (certificateToApi cert, wit <&> (\wit' -> (certificateToStakeCredential cert & stakeCredentialToApi, f wit'))) - where - f :: GYTxCertWitness v -> Api.Witness Api.WitCtxStake ApiEra - f GYTxCertWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr - f (GYTxCertWitnessScript v r) = - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - gyStakeValScriptWitnessToApiPlutusSW - v - (redeemerToApi r) - (Api.ExecutionUnits 0 0) + where + f :: GYTxCertWitness v -> Api.Witness Api.WitCtxStake ApiEra + f GYTxCertWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr + f (GYTxCertWitnessScript v r) = + Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ + gyStakeValScriptWitnessToApiPlutusSW + v + (redeemerToApi r) + (Api.ExecutionUnits 0 0) diff --git a/src/GeniusYield/Types/TxIn.hs b/src/GeniusYield/Types/TxIn.hs index bfd7b018..620c92c9 100644 --- a/src/GeniusYield/Types/TxIn.hs +++ b/src/GeniusYield/Types/TxIn.hs @@ -51,9 +51,9 @@ data GYTxInWitness v data GYInScript (u :: PlutusVersion) where -- | 'VersionIsGreaterOrEqual' restricts which version validators can be used in this transaction. - GYInScript :: forall u v. (v `VersionIsGreaterOrEqual` u) => GYValidator v -> GYInScript u + GYInScript :: forall u v. v `VersionIsGreaterOrEqual` u => GYValidator v -> GYInScript u -- | Reference inputs can be only used in V2 transactions. - GYInReference :: forall v. (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYInScript v + GYInReference :: forall v. v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYInScript v -- | Returns the 'PlutusVersion' of the given 'GYInScript'. inScriptVersion :: GYInScript v -> PlutusVersion @@ -74,7 +74,7 @@ instance Eq (GYInScript v) where data GYInSimpleScript (u :: PlutusVersion) where GYInSimpleScript :: !GYSimpleScript -> GYInSimpleScript u - GYInReferenceSimpleScript :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !GYSimpleScript -> GYInSimpleScript v + GYInReferenceSimpleScript :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !GYSimpleScript -> GYInSimpleScript v deriving instance Show (GYInSimpleScript v) @@ -93,20 +93,20 @@ txInToApi :: GYTxIn v -> (Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn ApiEra)) txInToApi useInline (GYTxIn oref m) = (txOutRefToApi oref, Api.BuildTxWith $ f m) - where - f :: GYTxInWitness v -> Api.Witness Api.WitCtxTxIn ApiEra - f GYTxInWitnessKey = Api.KeyWitness Api.KeyWitnessForSpending - f (GYTxInWitnessScript v d r) = - Api.ScriptWitness Api.ScriptWitnessForSpending $ - ( case v of - GYInScript s -> validatorToApiPlutusScriptWitness s - GYInReference ref s -> referenceScriptToApiPlutusScriptWitness ref s - ) - (if useInline then Api.InlineScriptDatum else Api.ScriptDatumForTxIn $ Just $ datumToApi' d) - (redeemerToApi r) - (Api.ExecutionUnits 0 0) - f (GYTxInWitnessSimpleScript v) = - Api.ScriptWitness Api.ScriptWitnessForSpending $ Api.SimpleScriptWitness Api.SimpleScriptInConway $ h v - - h (GYInSimpleScript v) = Api.SScript $ simpleScriptToApi v - h (GYInReferenceSimpleScript ref s) = Api.SReferenceScript (txOutRefToApi ref) $ Just $ hashSimpleScript' s + where + f :: GYTxInWitness v -> Api.Witness Api.WitCtxTxIn ApiEra + f GYTxInWitnessKey = Api.KeyWitness Api.KeyWitnessForSpending + f (GYTxInWitnessScript v d r) = + Api.ScriptWitness Api.ScriptWitnessForSpending $ + ( case v of + GYInScript s -> validatorToApiPlutusScriptWitness s + GYInReference ref s -> referenceScriptToApiPlutusScriptWitness ref s + ) + (if useInline then Api.InlineScriptDatum else Api.ScriptDatumForTxIn $ Just $ datumToApi' d) + (redeemerToApi r) + (Api.ExecutionUnits 0 0) + f (GYTxInWitnessSimpleScript v) = + Api.ScriptWitness Api.ScriptWitnessForSpending $ Api.SimpleScriptWitness Api.SimpleScriptInConway $ h v + + h (GYInSimpleScript v) = Api.SScript $ simpleScriptToApi v + h (GYInReferenceSimpleScript ref s) = Api.SReferenceScript (txOutRefToApi ref) $ Just $ hashSimpleScript' s diff --git a/src/GeniusYield/Types/TxMetadata.hs b/src/GeniusYield/Types/TxMetadata.hs index 54bc86d8..e8d343a1 100644 --- a/src/GeniusYield/Types/TxMetadata.hs +++ b/src/GeniusYield/Types/TxMetadata.hs @@ -126,6 +126,6 @@ metadataMsgs :: [Text] -> Maybe GYTxMetadata metadataMsgs msgs = case metaValue of GYTxMetaList [] -> Nothing _ -> Just $ GYTxMetadata $ Map.fromList [(674, GYTxMetaMap [(GYTxMetaText "msg", metaValue)])] - where - metaValue :: GYTxMetadataValue - metaValue = txMetadataValueFromApi $ Api.TxMetaList $ concatMap constructTxMetadataTextChunks' msgs + where + metaValue :: GYTxMetadataValue + metaValue = txMetadataValueFromApi $ Api.TxMetaList $ concatMap constructTxMetadataTextChunks' msgs diff --git a/src/GeniusYield/Types/TxOut.hs b/src/GeniusYield/Types/TxOut.hs index 9548fe41..aaee4a72 100644 --- a/src/GeniusYield/Types/TxOut.hs +++ b/src/GeniusYield/Types/TxOut.hs @@ -39,7 +39,7 @@ data GYTxOut (v :: PlutusVersion) = GYTxOut deriving stock (Eq, Show) data GYTxOutUseInlineDatum (v :: PlutusVersion) where - GYTxOutUseInlineDatum :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => GYTxOutUseInlineDatum v + GYTxOutUseInlineDatum :: v `VersionIsGreaterOrEqual` 'PlutusV2 => GYTxOutUseInlineDatum v GYTxOutDontUseInlineDatum :: GYTxOutUseInlineDatum v deriving instance Show (GYTxOutUseInlineDatum v) @@ -79,20 +79,20 @@ txOutToApi (GYTxOut addr v md mrs) = (valueToApiTxOutValue v) (mkDatum md) (maybe Api.S.ReferenceScriptNone (Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway . resolveOutputScript) mrs) - where - resolveOutputScript (GYSimpleScript s) = Api.ScriptInAnyLang Api.SimpleScriptLanguage (Api.SimpleScript $ simpleScriptToApi s) - resolveOutputScript (GYPlutusScript s) = - let version = singPlutusVersionToApi $ scriptVersion s - in Api.ScriptInAnyLang (Api.PlutusScriptLanguage version) (Api.PlutusScript version (scriptToApi s)) + where + resolveOutputScript (GYSimpleScript s) = Api.ScriptInAnyLang Api.SimpleScriptLanguage (Api.SimpleScript $ simpleScriptToApi s) + resolveOutputScript (GYPlutusScript s) = + let version = singPlutusVersionToApi $ scriptVersion s + in Api.ScriptInAnyLang (Api.PlutusScriptLanguage version) (Api.PlutusScript version (scriptToApi s)) - mkDatum :: Maybe (GYDatum, GYTxOutUseInlineDatum v) -> Api.TxOutDatum Api.CtxTx ApiEra - mkDatum Nothing = Api.TxOutDatumNone - mkDatum (Just (d, di)) - | di' = Api.TxOutDatumInline Api.BabbageEraOnwardsConway d' - | otherwise = Api.TxOutDatumInTx Api.AlonzoEraOnwardsConway d' - where - d' = datumToApi' d + mkDatum :: Maybe (GYDatum, GYTxOutUseInlineDatum v) -> Api.TxOutDatum Api.CtxTx ApiEra + mkDatum Nothing = Api.TxOutDatumNone + mkDatum (Just (d, di)) + | di' = Api.TxOutDatumInline Api.BabbageEraOnwardsConway d' + | otherwise = Api.TxOutDatumInTx Api.AlonzoEraOnwardsConway d' + where + d' = datumToApi' d - di' = case di of - GYTxOutUseInlineDatum -> True - GYTxOutDontUseInlineDatum -> False + di' = case di of + GYTxOutUseInlineDatum -> True + GYTxOutDontUseInlineDatum -> False diff --git a/src/GeniusYield/Types/TxOutRef.hs b/src/GeniusYield/Types/TxOutRef.hs index af6615c4..19d98420 100644 --- a/src/GeniusYield/Types/TxOutRef.hs +++ b/src/GeniusYield/Types/TxOutRef.hs @@ -89,17 +89,17 @@ Left (UnknownPlutusToCardanoError {ptceTag = "txOutRefFromPlutus: txOutRefIdx 12 -} txOutRefFromPlutus :: Plutus.TxOutRef -> Either PlutusToCardanoError GYTxOutRef txOutRefFromPlutus (Plutus.TxOutRef tid@(Plutus.TxId (Plutus.BuiltinByteString bs)) ix) = coerce . Api.TxIn <$> etid <*> eix - where - etid :: Either PlutusToCardanoError Api.TxId - etid = - mapLeft (\e -> UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: invalid txOutRefId " <> show tid <> ", error: " <> show e) $ - Api.deserialiseFromRawBytes Api.AsTxId bs - - eix :: Either PlutusToCardanoError Api.TxIx - eix - | ix < 0 = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: negative txOutRefIdx " ++ show ix - | ix > toInteger (maxBound @Word) = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: txOutRefIdx " ++ show ix ++ " too large" - | otherwise = Right $ Api.TxIx $ fromInteger ix + where + etid :: Either PlutusToCardanoError Api.TxId + etid = + mapLeft (\e -> UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: invalid txOutRefId " <> show tid <> ", error: " <> show e) $ + Api.deserialiseFromRawBytes Api.AsTxId bs + + eix :: Either PlutusToCardanoError Api.TxIx + eix + | ix < 0 = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: negative txOutRefIdx " ++ show ix + | ix > toInteger (maxBound @Word) = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: txOutRefIdx " ++ show ix ++ " too large" + | otherwise = Right $ Api.TxIx $ fromInteger ix {- | @@ -143,14 +143,14 @@ instance Web.FromHttpApiData GYTxOutRef where parseUrlPiece tr = case Atto.parseOnly parser (TE.encodeUtf8 tr) of Left err -> Left (T.pack ("GYTxOutRef: " ++ err)) Right x -> Right x - where - parser :: Atto.Parser GYTxOutRef - parser = do - tx <- Base16.decodeLenient <$> Atto.takeWhile1 isHexDigit - _ <- Atto.char '#' - ix <- Atto.decimal - tx' <- either (\e -> fail $ "not txid bytes: " <> show tx <> " , error: " <> show e) pure $ Api.deserialiseFromRawBytes Api.AsTxId tx - return (GYTxOutRef (Api.TxIn tx' (Api.TxIx ix))) + where + parser :: Atto.Parser GYTxOutRef + parser = do + tx <- Base16.decodeLenient <$> Atto.takeWhile1 isHexDigit + _ <- Atto.char '#' + ix <- Atto.decimal + tx' <- either (\e -> fail $ "not txid bytes: " <> show tx <> " , error: " <> show e) pure $ Api.deserialiseFromRawBytes Api.AsTxId tx + return (GYTxOutRef (Api.TxIn tx' (Api.TxIx ix))) instance Web.ToHttpApiData GYTxOutRef where toUrlPiece = showTxOutRef diff --git a/src/GeniusYield/Types/TxWdrl.hs b/src/GeniusYield/Types/TxWdrl.hs index 59db48ab..d853cbb3 100644 --- a/src/GeniusYield/Types/TxWdrl.hs +++ b/src/GeniusYield/Types/TxWdrl.hs @@ -43,12 +43,12 @@ txWdrlToApi :: GYTxWdrl v -> (Api.StakeAddress, Ledger.Coin, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxStake ApiEra)) txWdrlToApi (GYTxWdrl stakeAddr amt wit) = (stakeAddressToApi stakeAddr, Ledger.Coin (toInteger amt), Api.BuildTxWith $ f wit) - where - f :: GYTxWdrlWitness v -> Api.Witness Api.WitCtxStake ApiEra - f GYTxWdrlWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr - f (GYTxWdrlWitnessScript v r) = - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - gyStakeValScriptWitnessToApiPlutusSW - v - (redeemerToApi r) - (Api.ExecutionUnits 0 0) + where + f :: GYTxWdrlWitness v -> Api.Witness Api.WitCtxStake ApiEra + f GYTxWdrlWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr + f (GYTxWdrlWitnessScript v r) = + Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ + gyStakeValScriptWitnessToApiPlutusSW + v + (redeemerToApi r) + (Api.ExecutionUnits 0 0) diff --git a/src/GeniusYield/Types/UTxO.hs b/src/GeniusYield/Types/UTxO.hs index 137a387b..0c8b762f 100644 --- a/src/GeniusYield/Types/UTxO.hs +++ b/src/GeniusYield/Types/UTxO.hs @@ -123,27 +123,27 @@ utxosFromApi (Api.UTxO m) = utxosToApi :: GYUTxOs -> Api.UTxO ApiEra utxosToApi (GYUTxOs m) = Api.UTxO $ Map.foldlWithKey' f Map.empty m - where - f :: - Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) -> - GYTxOutRef -> - (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> - Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) - f m' oref out = Map.insert (txOutRefToApi oref) (g out) m' - - g :: (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> Api.TxOut Api.CtxUTxO ApiEra - g (addr, v, md, ms) = - Api.TxOut - (addressToApi' addr) - (valueToApiTxOutValue v) - (outDatumToApi md) - (maybe Api.S.ReferenceScriptNone someScriptToReferenceApi ms) - - outDatumToApi GYOutDatumNone = Api.TxOutDatumNone - outDatumToApi (GYOutDatumHash h) = - Api.TxOutDatumHash Api.AlonzoEraOnwardsConway $ datumHashToApi h - outDatumToApi (GYOutDatumInline d) = - Api.TxOutDatumInline Api.BabbageEraOnwardsConway $ datumToApi' d + where + f :: + Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) -> + GYTxOutRef -> + (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> + Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) + f m' oref out = Map.insert (txOutRefToApi oref) (g out) m' + + g :: (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> Api.TxOut Api.CtxUTxO ApiEra + g (addr, v, md, ms) = + Api.TxOut + (addressToApi' addr) + (valueToApiTxOutValue v) + (outDatumToApi md) + (maybe Api.S.ReferenceScriptNone someScriptToReferenceApi ms) + + outDatumToApi GYOutDatumNone = Api.TxOutDatumNone + outDatumToApi (GYOutDatumHash h) = + Api.TxOutDatumHash Api.AlonzoEraOnwardsConway $ datumHashToApi h + outDatumToApi (GYOutDatumInline d) = + Api.TxOutDatumInline Api.BabbageEraOnwardsConway $ datumToApi' d utxoFromApi :: Api.TxIn -> Api.TxOut Api.CtxTx ApiEra -> GYUTxO utxoFromApi txIn (Api.TxOut a v d s) = @@ -154,12 +154,12 @@ utxoFromApi txIn (Api.TxOut a v d s) = , utxoOutDatum = f d , utxoRefScript = someScriptFromReferenceApi s } - where - f :: Api.TxOutDatum Api.CtxTx ApiEra -> GYOutDatum - f Api.TxOutDatumNone = GYOutDatumNone - f (Api.TxOutDatumHash _ hash) = GYOutDatumHash $ datumHashFromApi hash - f (Api.TxOutDatumInTx _ sd) = GYOutDatumHash . hashDatum $ datumFromApi' sd - f (Api.TxOutDatumInline _ sd) = GYOutDatumInline $ datumFromApi' sd + where + f :: Api.TxOutDatum Api.CtxTx ApiEra -> GYOutDatum + f Api.TxOutDatumNone = GYOutDatumNone + f (Api.TxOutDatumHash _ hash) = GYOutDatumHash $ datumHashFromApi hash + f (Api.TxOutDatumInTx _ sd) = GYOutDatumHash . hashDatum $ datumFromApi' sd + f (Api.TxOutDatumInline _ sd) = GYOutDatumInline $ datumFromApi' sd utxoFromApi' :: Api.TxIn -> Api.TxOut Api.CtxUTxO era -> GYUTxO utxoFromApi' txIn (Api.TxOut a v d s) = @@ -170,11 +170,11 @@ utxoFromApi' txIn (Api.TxOut a v d s) = , utxoOutDatum = f d , utxoRefScript = someScriptFromReferenceApi s } - where - f :: Api.TxOutDatum Api.CtxUTxO era -> GYOutDatum - f Api.TxOutDatumNone = GYOutDatumNone - f (Api.TxOutDatumHash _ hash) = GYOutDatumHash $ datumHashFromApi hash - f (Api.TxOutDatumInline _ sd) = GYOutDatumInline $ datumFromApi' sd + where + f :: Api.TxOutDatum Api.CtxUTxO era -> GYOutDatum + f Api.TxOutDatumNone = GYOutDatumNone + f (Api.TxOutDatumHash _ hash) = GYOutDatumHash $ datumHashFromApi hash + f (Api.TxOutDatumInline _ sd) = GYOutDatumInline $ datumFromApi' sd utxoToPlutus :: GYUTxO -> Plutus.TxOut utxoToPlutus GYUTxO {..} = @@ -234,11 +234,11 @@ Used to pick an input for minting, or selecting collateral (in tests). -} someTxOutRef :: GYUTxOs -> Maybe (GYTxOutRef, GYUTxOs) someTxOutRef (GYUTxOs m) = f <$> Map.minViewWithKey m - where - f ((oref, _), m') = (oref, GYUTxOs m') + where + f ((oref, _), m') = (oref, GYUTxOs m') -- | Get a random output reference from 'GYUTxOs'. -randomTxOutRef :: (MonadRandom m) => GYUTxOs -> m (Maybe (GYTxOutRef, GYUTxOs)) +randomTxOutRef :: MonadRandom m => GYUTxOs -> m (Maybe (GYTxOutRef, GYUTxOs)) randomTxOutRef (GYUTxOs m) | Map.null m = pure Nothing | otherwise = @@ -251,24 +251,24 @@ randomTxOutRef (GYUTxOs m) -- | Filter 'GYUTxOs' with a predicate on 'GYUTxO'. filterUTxOs :: (GYUTxO -> Bool) -> GYUTxOs -> GYUTxOs filterUTxOs p (GYUTxOs m) = GYUTxOs $ Map.filterWithKey p' m - where - p' r (a, v, mh, ms) = p $ GYUTxO r a v mh ms + where + p' r (a, v, mh, ms) = p $ GYUTxO r a v mh ms -- | Map & filter 'GYUTxOs' contents. mapMaybeUTxOs :: (GYUTxO -> Maybe a) -> GYUTxOs -> Map GYTxOutRef a mapMaybeUTxOs p (GYUTxOs m) = Map.mapMaybeWithKey p' m - where - p' r (a, v, mh, ms) = p $ GYUTxO r a v mh ms + where + p' r (a, v, mh, ms) = p $ GYUTxO r a v mh ms -- | Map 'GYUTxOs' contents. mapUTxOs :: (GYUTxO -> a) -> GYUTxOs -> Map GYTxOutRef a mapUTxOs f = mapMaybeUTxOs $ Just . f -- | Applicative version of 'mapMaybeUTxOs'. -witherUTxOs :: (Applicative f) => (GYUTxO -> f (Maybe a)) -> GYUTxOs -> f (Map GYTxOutRef a) +witherUTxOs :: Applicative f => (GYUTxO -> f (Maybe a)) -> GYUTxOs -> f (Map GYTxOutRef a) witherUTxOs f (GYUTxOs m) = iwither g m - where - g ref (a, v, mh, ms) = f (GYUTxO ref a v mh ms) + where + g ref (a, v, mh, ms) = f (GYUTxO ref a v mh ms) -- | Returns a 'GYUTxOs' from a given list of 'GYUTxO's. utxosFromList :: [GYUTxO] -> GYUTxOs @@ -294,25 +294,25 @@ utxosFromUTxO utxo = utxosFromList [utxo] -- | Fold operation over a 'GYUTxOs'. foldlUTxOs' :: forall a. (a -> GYUTxO -> a) -> a -> GYUTxOs -> a foldlUTxOs' f x (GYUTxOs m) = Map.foldlWithKey' f' x m - where - f' :: a -> GYTxOutRef -> (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> a - f' y r (a, v, mh, ms) = f y $ GYUTxO r a v mh ms + where + f' :: a -> GYTxOutRef -> (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> a + f' y r (a, v, mh, ms) = f y $ GYUTxO r a v mh ms -- | FoldMap operation over a 'GYUTxOs'. -foldMapUTxOs :: (Monoid m) => (GYUTxO -> m) -> GYUTxOs -> m +foldMapUTxOs :: Monoid m => (GYUTxO -> m) -> GYUTxOs -> m foldMapUTxOs f = foldlUTxOs' (\m utxo -> m <> f utxo) mempty -forUTxOs_ :: forall f a. (Applicative f) => GYUTxOs -> (GYUTxO -> f a) -> f () +forUTxOs_ :: forall f a. Applicative f => GYUTxOs -> (GYUTxO -> f a) -> f () forUTxOs_ (GYUTxOs m) f = ifor_ m f' - where - f' :: GYTxOutRef -> (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> f a - f' r (a, v, mh, ms) = f $ GYUTxO r a v mh ms + where + f' :: GYTxOutRef -> (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> f a + f' r (a, v, mh, ms) = f $ GYUTxO r a v mh ms -foldMUTxOs :: forall m a. (Monad m) => (a -> GYUTxO -> m a) -> a -> GYUTxOs -> m a +foldMUTxOs :: forall m a. Monad m => (a -> GYUTxO -> m a) -> a -> GYUTxOs -> m a foldMUTxOs f x (GYUTxOs m) = foldM f' x $ Map.toList m - where - f' :: a -> (GYTxOutRef, (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript)) -> m a - f' y (r, (a, v, mh, ms)) = f y $ GYUTxO r a v mh ms + where + f' :: a -> (GYTxOutRef, (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript)) -> m a + f' y (r, (a, v, mh, ms)) = f y $ GYUTxO r a v mh ms instance Printf.PrintfArg GYUTxOs where formatArg (GYUTxOs m) = diff --git a/src/GeniusYield/Types/Value.hs b/src/GeniusYield/Types/Value.hs index 9159016a..07709c80 100644 --- a/src/GeniusYield/Types/Value.hs +++ b/src/GeniusYield/Types/Value.hs @@ -141,8 +141,8 @@ data GYFromPlutusValueError -- | Value: a (total) map from asset classes ('GYAssetClass') to amount ('Integer'). newtype GYValue = GYValue (Map.Map GYAssetClass Integer) - deriving (Eq) - deriving newtype (Ord) + deriving Eq + deriving newtype Ord {- | Check the 'GYValue' representation invariants. @@ -170,9 +170,9 @@ instance Monoid GYValue where -- | Converts a 'GYValue' to a Plutus 'Plutus.Value' valueToPlutus :: GYValue -> Plutus.Value valueToPlutus (GYValue m) = foldMap f (Map.toList m) - where - f :: (GYAssetClass, Integer) -> Plutus.Value - f (assetClassToPlutus -> Plutus.AssetClass (cs, tn), n) = Plutus.singleton cs tn n + where + f :: (GYAssetClass, Integer) -> Plutus.Value + f (assetClassToPlutus -> Plutus.AssetClass (cs, tn), n) = Plutus.singleton cs tn n {- | Converts a Plutus 'Plutus.Value' to a 'GYValue'. Returns Left 'GYFromPlutusValueError' if it fails. @@ -278,9 +278,9 @@ instance Printf.PrintfArg GYValue where showValue :: Plutus.Value -> String showValue = intercalate " + " . map f . Plutus.flattenValue - where - f :: (Plutus.CurrencySymbol, Plutus.TokenName, Integer) -> String - f (cs, tn, n) = show n ++ " " ++ showAssetClass (Plutus.AssetClass (cs, tn)) + where + f :: (Plutus.CurrencySymbol, Plutus.TokenName, Integer) -> String + f (cs, tn, n) = show n ++ " " ++ showAssetClass (Plutus.AssetClass (cs, tn)) {- | @@ -300,11 +300,11 @@ instance Csv.FromField GYValue where Just v -> pure v Nothing -> fail $ "Error Parsing GYValue: " <> show value -assetPairToKV :: (Aeson.KeyValue e kv) => GYAssetClass -> Integer -> kv +assetPairToKV :: Aeson.KeyValue e kv => GYAssetClass -> Integer -> kv assetPairToKV ac i = K.fromText (f ac) .= i - where - f GYLovelace = "lovelace" - f (GYToken cs tk) = mintingPolicyIdToText cs <> T.cons '.' (tokenNameToHex tk) + where + f GYLovelace = "lovelace" + f (GYToken cs tk) = mintingPolicyIdToText cs <> T.cons '.' (tokenNameToHex tk) {- | @@ -325,18 +325,18 @@ parseValueKM allowWithoutSep km = case KM.toList km of [] -> pure $ valueMake mempty xs -> valueFromList <$> traverse go xs - where - go :: (Aeson.Key, Aeson.Value) -> Aeson.Parser (GYAssetClass, Integer) - go (k, v) = do - let k' = K.toText k - parseWithSep = parseAssetClassWithSep '.' k' - ac <- - either fail pure $ - either (\(Left -> e) -> if allowWithoutSep then parseAssetClassWithoutSep k' <> e else e) Right parseWithSep - scN <- parseJSON v - case SC.floatingOrInteger @Double scN of - Left d -> fail $ "Expected amount to be an integer; amount: " <> show d - Right i -> pure (ac, i) + where + go :: (Aeson.Key, Aeson.Value) -> Aeson.Parser (GYAssetClass, Integer) + go (k, v) = do + let k' = K.toText k + parseWithSep = parseAssetClassWithSep '.' k' + ac <- + either fail pure $ + either (\(Left -> e) -> if allowWithoutSep then parseAssetClassWithoutSep k' <> e else e) Right parseWithSep + scN <- parseJSON v + case SC.floatingOrInteger @Double scN of + Left d -> fail $ "Expected amount to be an integer; amount: " <> show d + Right i -> pure (ac, i) instance Swagger.ToSchema GYValue where declareNamedSchema _ = do @@ -409,8 +409,8 @@ valueAssetClass (GYValue m) ac = Map.findWithDefault 0 ac m -} valueSplitSign :: GYValue -> (GYValue, GYValue) valueSplitSign (GYValue m) = (GYValue positiveVal, GYValue $ negate <$> negativeVal) - where - (positiveVal, negativeVal) = Map.partition (> 0) m + where + (positiveVal, negativeVal) = Map.partition (> 0) m -- | Verify the value only consists of positive amounts, returning a map containing naturals as a result. valueVerifyNonNegative :: GYValue -> Maybe (Map GYAssetClass Natural) @@ -656,11 +656,11 @@ parseAssetClass msep = case msep of Just sep -> parseAssetClassCore sep tnParser Nothing -> parseAssetClassCore' Nothing tnParser - where - tnParser tn = - case tokenNameFromHexBS tn of - Left err -> fail $ T.unpack err - Right x -> pure x + where + tnParser tn = + case tokenNameFromHexBS tn of + Left err -> fail $ T.unpack err + Right x -> pure x parseAssetClassCore :: Char -> (BS.ByteString -> Atto.Parser GYTokenName) -> Text -> Either String GYAssetClass parseAssetClassCore = parseAssetClassCore' . Just @@ -669,16 +669,16 @@ parseAssetClassCore' :: Maybe Char -> (BS.ByteString -> Atto.Parser GYTokenName) parseAssetClassCore' _ _ "lovelace" = pure GYLovelace parseAssetClassCore' _ _ "" = pure GYLovelace parseAssetClassCore' msep tkParser t = Atto.parseOnly parser (TE.encodeUtf8 t) - where - parser :: Atto.Parser GYAssetClass - parser = do - cs <- Atto.take 56 - case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of - Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x - Right cs' -> do - for_ msep (void . Atto.char) - tn <- Atto.takeWhile isAlphaNum - GYToken (mintingPolicyIdFromApi cs') <$> tkParser tn + where + parser :: Atto.Parser GYAssetClass + parser = do + cs <- Atto.take 56 + case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of + Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x + Right cs' -> do + for_ msep (void . Atto.char) + tn <- Atto.takeWhile isAlphaNum + GYToken (mintingPolicyIdFromApi cs') <$> tkParser tn ------------------------------------------------------------------------------- -- TokenName @@ -706,8 +706,8 @@ instance IsString GYTokenName where fromMaybe (error $ "fromString @GYTokenName " ++ show s ++ ": token name too long") (tokenNameFromBS bs) - where - bs = fromString s -- TODO: utf8-encode #33 (https://github.com/geniusyield/atlas/issues/33) + where + bs = fromString s -- TODO: utf8-encode #33 (https://github.com/geniusyield/atlas/issues/33) instance Swagger.ToParamSchema GYTokenName where toParamSchema _ = @@ -787,7 +787,7 @@ tokenNameToPlutus :: GYTokenName -> Plutus.TokenName tokenNameToPlutus (GYTokenName bs) = Plutus.TokenName (toBuiltin bs) -- | Convert Plutus 'Plutus.TokenName' to 'GYTokenName'. -tokenNameFromPlutus :: (HasCallStack) => Plutus.TokenName -> Maybe GYTokenName +tokenNameFromPlutus :: HasCallStack => Plutus.TokenName -> Maybe GYTokenName tokenNameFromPlutus (Plutus.TokenName bbs) = tokenNameFromBS (fromBuiltin bbs) tokenNameFromBS :: BS.ByteString -> Maybe GYTokenName diff --git a/src/GeniusYield/Types/Wallet.hs b/src/GeniusYield/Types/Wallet.hs index 83619b23..c4a913ae 100644 --- a/src/GeniusYield/Types/Wallet.hs +++ b/src/GeniusYield/Types/Wallet.hs @@ -68,25 +68,25 @@ walletKeysFromMnemonicIndexed mns nAcctIndex nAddrIndex = accIx = indexFromWord32 $ minHardenedPathValue + nAcctIndex addrIx = indexFromWord32 nAddrIndex in deriveWalletKeys rootK accIx addrIx - where - deriveWalletKeys :: - S.Shelley 'RootK XPrv -> - -- \^ The Root Key - Maybe (Index 'Hardened 'AccountK) -> - -- \^ The Index for Account - Maybe (Index 'Soft 'PaymentK) -> - -- \^ The Index for Address - Either String WalletKeys - deriveWalletKeys _ Nothing _ = Left $ "Invalid Account Index: " <> show nAcctIndex - deriveWalletKeys _ _ Nothing = Left $ "Invalid Address Index: " <> show nAddrIndex - deriveWalletKeys rootK (Just accIx) (Just addIx) = - let acctK = deriveAccountPrivateKey rootK accIx - paymentK = deriveAddressPrivateKey acctK S.UTxOExternal addIx - stakeK = S.deriveDelegationPrivateKey acctK - in Right WalletKeys {wkRootKey = rootK, wkAcctKey = acctK, wkPaymentKey = paymentK, wkStakeKey = stakeK} + where + deriveWalletKeys :: + S.Shelley 'RootK XPrv -> + -- \^ The Root Key + Maybe (Index 'Hardened 'AccountK) -> + -- \^ The Index for Account + Maybe (Index 'Soft 'PaymentK) -> + -- \^ The Index for Address + Either String WalletKeys + deriveWalletKeys _ Nothing _ = Left $ "Invalid Account Index: " <> show nAcctIndex + deriveWalletKeys _ _ Nothing = Left $ "Invalid Address Index: " <> show nAddrIndex + deriveWalletKeys rootK (Just accIx) (Just addIx) = + let acctK = deriveAccountPrivateKey rootK accIx + paymentK = deriveAddressPrivateKey acctK S.UTxOExternal addIx + stakeK = S.deriveDelegationPrivateKey acctK + in Right WalletKeys {wkRootKey = rootK, wkAcctKey = acctK, wkPaymentKey = paymentK, wkStakeKey = stakeK} - -- value for '0H' index - minHardenedPathValue = 0x80000000 + -- value for '0H' index + minHardenedPathValue = 0x80000000 -- | Derives @WalletKeys@ from mnemonic with first account index, using derivation path @1852H/1815H/0H/2/0@ for stake key and derivation path @1852H/1815H/0H/0/0@ for payment key. walletKeysFromMnemonic :: Mnemonic -> Either String WalletKeys @@ -126,10 +126,10 @@ walletKeysToAddress WalletKeys {wkPaymentKey, wkStakeKey} netId = let paymentCredential = S.PaymentFromExtendedKey $ toXPub <$> wkPaymentKey delegationCredential = S.DelegationFromExtendedKey $ toXPub <$> wkStakeKey in S.delegationAddress netId' paymentCredential delegationCredential & bech32 & unsafeAddressFromText - where - netId' = case netId of - GYMainnet -> S.shelleyMainnet - GYTestnetPreprod -> S.shelleyTestnet - GYTestnetPreview -> S.shelleyTestnet - GYTestnetLegacy -> S.shelleyTestnet - GYPrivnet {} -> S.shelleyTestnet + where + netId' = case netId of + GYMainnet -> S.shelleyMainnet + GYTestnetPreprod -> S.shelleyTestnet + GYTestnetPreview -> S.shelleyTestnet + GYTestnetLegacy -> S.shelleyTestnet + GYPrivnet {} -> S.shelleyTestnet diff --git a/src/GeniusYield/Utils.hs b/src/GeniusYield/Utils.hs index 2a0649a0..713eb706 100644 --- a/src/GeniusYield/Utils.hs +++ b/src/GeniusYield/Utils.hs @@ -37,10 +37,10 @@ fieldNamePrefixStripN :: Int -> String -> String fieldNamePrefixStripN n fldName = case drop n fldName of x : xs -> toLower x : xs; [] -> [] -- | Map the exception type in an 'ExceptT' with a function. -modifyException :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a +modifyException :: Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a modifyException f (ExceptT meith) = ExceptT $ first f <$> meith -serialiseToBech32WithPrefix :: (SerialiseAsRawBytes a) => Text -> a -> Text +serialiseToBech32WithPrefix :: SerialiseAsRawBytes a => Text -> a -> Text serialiseToBech32WithPrefix prefix = case Bech32.humanReadablePartFromText prefix of Left e -> diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index 1ac09db1..181f144a 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -43,43 +43,43 @@ placeBetTests setup = ) . failingMultipleBetsTest ] - where - mkPrivnetTestFor_ = flip mkPrivnetTestFor setup - firstBetTest :: (GYTxGameMonad m) => TestInfo -> m () - firstBetTest = firstBetTrace (OracleAnswerDatum 3) (valueFromLovelace 20_000_000) . testWallets - multipleBetsTest :: (GYTxGameMonad m) => TestInfo -> m () - multipleBetsTest TestInfo {..} = - multipleBetsTraceWrapper - 400 - 1_000 - (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) - ] - testWallets - failingMultipleBetsTest :: (GYTxGameMonad m) => TestInfo -> m () - failingMultipleBetsTest TestInfo {..} = - multipleBetsTraceWrapper - 400 - 1_000 - (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 55_000_000 <> valueSingleton testGoldAsset 1_000) - ] - testWallets + where + mkPrivnetTestFor_ = flip mkPrivnetTestFor setup + firstBetTest :: GYTxGameMonad m => TestInfo -> m () + firstBetTest = firstBetTrace (OracleAnswerDatum 3) (valueFromLovelace 20_000_000) . testWallets + multipleBetsTest :: GYTxGameMonad m => TestInfo -> m () + multipleBetsTest TestInfo {..} = + multipleBetsTraceWrapper + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + testWallets + failingMultipleBetsTest :: GYTxGameMonad m => TestInfo -> m () + failingMultipleBetsTest TestInfo {..} = + multipleBetsTraceWrapper + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 55_000_000 <> valueSingleton testGoldAsset 1_000) + ] + testWallets -- ----------------------------------------------------------------------------- -- Super-trivial example -- ----------------------------------------------------------------------------- -- | Trace for a super-simple spending transaction. -simplSpendingTxTrace :: (GYTxGameMonad m) => Wallets -> m () +simplSpendingTxTrace :: GYTxGameMonad m => Wallets -> m () simplSpendingTxTrace Wallets {w1} = do gyLogDebug' "" "Hey there!" -- balance assetion check @@ -93,7 +93,7 @@ simplSpendingTxTrace Wallets {w1} = do gyLogDebug' "" $ printf "tx submitted, txId: %s" txId -- Pretend off-chain code written in 'GYTxUserQueryMonad m' -mkTrivialTx :: (GYTxUserQueryMonad m) => m (GYTxSkeleton 'PlutusV2) +mkTrivialTx :: GYTxUserQueryMonad m => m (GYTxSkeleton 'PlutusV2) mkTrivialTx = do addr <- ownChangeAddress gyLogDebug' "" $ printf "ownAddr: %s" (show addr) @@ -127,7 +127,7 @@ Level 3. The action (Off-chain code) -- | Trace for placing the first bet. firstBetTrace :: - (GYTxGameMonad m) => + GYTxGameMonad m => -- | Guess OracleAnswerDatum -> -- | Bet @@ -148,7 +148,7 @@ firstBetTrace dat bet ws@Wallets {w1} = do -- | Function to compute the parameters for the contract and add the corresponding refernce script. computeParamsAndAddRefScript :: - (GYTxGameMonad m) => + GYTxGameMonad m => -- | Bet Until slot Integer -> -- | Bet Reveal slot @@ -179,7 +179,7 @@ computeParamsAndAddRefScript betUntil' betReveal' betStep Wallets {..} = do pure (brp, refScript) -- | Run to call the `placeBet` operation. -placeBetRun :: (GYTxMonad m) => GYTxOutRef -> BetRefParams -> OracleAnswerDatum -> GYValue -> Maybe GYTxOutRef -> m GYTxId +placeBetRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> OracleAnswerDatum -> GYValue -> Maybe GYTxOutRef -> m GYTxId placeBetRun refScript brp guess bet mPreviousBetsUtxoRef = do addr <- ownChangeAddress gyLogDebug' "" $ printf "bet: %s" (show bet) @@ -197,7 +197,7 @@ placeBetRun refScript brp guess bet mPreviousBetsUtxoRef = do -- | Trace which allows for multiple bets. multipleBetsTraceWrapper :: - (GYTxGameMonad m) => + GYTxGameMonad m => -- | slot for betUntil Integer -> -- | slot for betReveal @@ -219,7 +219,7 @@ multipleBetsTraceWrapper betUntil' betReveal' betStep walletBets ws = do -- | Trace which allows for multiple bets. multipleBetsTraceCore :: - (GYTxGameMonad m) => + GYTxGameMonad m => BetRefParams -> -- | Reference script GYTxOutRef -> @@ -272,26 +272,26 @@ multipleBetsTraceCore brp refScript walletBets ws@Wallets {..} = do gyLogDebug' "" $ printf "balanceAfterAllTheseOps: %s" (mconcat balanceAfterAllTheseOps) -- Check the difference asUser w1 $ verify (zip3 balanceDiffWithoutFees balanceBeforeAllTheseOps balanceAfterAllTheseOps) - where - -- \| Function to verify that the wallet indeed lost by /roughly/ the bet amount. - -- We say /roughly/ as fees is assumed to be within (0, 1.5 ada]. - -- Suppose that wallet x places bet 3 times, where for simplicity assume each tx costed 0.6 ada as fees then the threshold should be above 1.8 ada. - verify [] = return () - verify (((wallet, diff), vBefore, vAfter) : xs) = - let vAfterWithoutFees = vBefore <> diff - (expectedAdaWithoutFees, expectedOtherAssets) = valueSplitAda vAfterWithoutFees - (actualAda, actualOtherAssets) = valueSplitAda vAfter - threshold = 1_500_000 -- 1.5 ada - in if expectedOtherAssets == actualOtherAssets - && actualAda < expectedAdaWithoutFees - && expectedAdaWithoutFees - threshold <= actualAda - then verify xs - else - throwAppError . someBackendError . T.pack $ - ( "For wallet " - <> show (userAddr wallet) - <> " expected value (without fees) " - <> show vAfterWithoutFees - <> " but actual is " - <> show vAfter - ) + where + -- \| Function to verify that the wallet indeed lost by /roughly/ the bet amount. + -- We say /roughly/ as fees is assumed to be within (0, 1.5 ada]. + -- Suppose that wallet x places bet 3 times, where for simplicity assume each tx costed 0.6 ada as fees then the threshold should be above 1.8 ada. + verify [] = return () + verify (((wallet, diff), vBefore, vAfter) : xs) = + let vAfterWithoutFees = vBefore <> diff + (expectedAdaWithoutFees, expectedOtherAssets) = valueSplitAda vAfterWithoutFees + (actualAda, actualOtherAssets) = valueSplitAda vAfter + threshold = 1_500_000 -- 1.5 ada + in if expectedOtherAssets == actualOtherAssets + && actualAda < expectedAdaWithoutFees + && expectedAdaWithoutFees - threshold <= actualAda + then verify xs + else + throwAppError . someBackendError . T.pack $ + ( "For wallet " + <> show (userAddr wallet) + <> " expected value (without fees) " + <> show vAfterWithoutFees + <> " but actual is " + <> show vAfter + ) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs index 140fedbd..da1f53bf 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -31,63 +31,63 @@ takeBetPotTests setup = , mkTestFor "Must fail even if old guess was closest but updated one is not" $ mustFail . badUpdatedGuessTakeBetsTest , mkPrivnetTestFor_ "Must fail even if old guess was closest but updated one is not - privnet" $ mustFailPrivnet . badUpdatedGuessTakeBetsTest ] - where - mkPrivnetTestFor_ = flip mkPrivnetTestFor setup - takeBetsTest :: (GYTxGameMonad m) => TestInfo -> m () - takeBetsTest TestInfo {..} = - takeBetsTrace - 400 - 1_000 - (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) - ] - 4 - w2 - testWallets - wrongGuesserTakeBetsTest :: (GYTxGameMonad m) => TestInfo -> m () - wrongGuesserTakeBetsTest TestInfo {..} = - takeBetsTrace - 400 - 1_000 - (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) - ] - 5 - w2 - testWallets - badUpdatedGuessTakeBetsTest :: (GYTxGameMonad m) => TestInfo -> m () - badUpdatedGuessTakeBetsTest TestInfo {..} = - takeBetsTrace - 400 - 1_000 - (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) - ] - 2 - w2 - testWallets - -- Must fail with script execution error (which is fired in the body error auto balance). - mustFailPrivnet = - handleError - ( \case - GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () - e -> throwError e - ) + where + mkPrivnetTestFor_ = flip mkPrivnetTestFor setup + takeBetsTest :: GYTxGameMonad m => TestInfo -> m () + takeBetsTest TestInfo {..} = + takeBetsTrace + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + 4 + w2 + testWallets + wrongGuesserTakeBetsTest :: GYTxGameMonad m => TestInfo -> m () + wrongGuesserTakeBetsTest TestInfo {..} = + takeBetsTrace + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + 5 + w2 + testWallets + badUpdatedGuessTakeBetsTest :: GYTxGameMonad m => TestInfo -> m () + badUpdatedGuessTakeBetsTest TestInfo {..} = + takeBetsTrace + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + 2 + w2 + testWallets + -- Must fail with script execution error (which is fired in the body error auto balance). + mustFailPrivnet = + handleError + ( \case + GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () + e -> throwError e + ) -- | Run to call the `takeBets` operation. -takeBetsRun :: (GYTxMonad m) => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId +takeBetsRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId takeBetsRun refScript brp toConsume refInput = do addr <- ownChangeAddress skeleton <- takeBets refScript brp toConsume addr refInput @@ -95,7 +95,7 @@ takeBetsRun refScript brp toConsume refInput = do -- | Trace for taking bet pot. takeBetsTrace :: - (GYTxGameMonad m) => + GYTxGameMonad m => -- | slot for betUntil Integer -> -- | slot for betReveal diff --git a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs index 6ad20a1b..eebb7e0c 100644 --- a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs +++ b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs @@ -144,23 +144,23 @@ mkBetRefValidator' (BetRefParams oraclePkh betUntil betReveal betStep) (BetRefDa && traceIfFalse "Guess is not closest" (all (\pg -> getGuessDiff (snd pg) >= guessDiff) previousGuesses) - where - info :: TxInfo - info = scriptContextTxInfo ctx - - validRange :: POSIXTimeRange - validRange = txInfoValidRange info - - signerPkh :: PubKeyHash - signerPkh = case txInfoSignatories info of - [signerPkh'] -> signerPkh' - [] -> traceError "No signatory" - _anyOtherMatch -> traceError "Expected only one signatory" - - outputToDatum :: (FromData b) => TxOut -> Maybe b - outputToDatum o = case txOutDatum o of - NoOutputDatum -> Nothing - OutputDatum d -> processDatum d - OutputDatumHash dh -> processDatum =<< findDatum dh info - where - processDatum = fromBuiltinData . getDatum + where + info :: TxInfo + info = scriptContextTxInfo ctx + + validRange :: POSIXTimeRange + validRange = txInfoValidRange info + + signerPkh :: PubKeyHash + signerPkh = case txInfoSignatories info of + [signerPkh'] -> signerPkh' + [] -> traceError "No signatory" + _anyOtherMatch -> traceError "Expected only one signatory" + + outputToDatum :: FromData b => TxOut -> Maybe b + outputToDatum o = case txOutDatum o of + NoOutputDatum -> Nothing + OutputDatum d -> processDatum d + OutputDatumHash dh -> processDatum =<< findDatum dh info + where + processDatum = fromBuiltinData . getDatum diff --git a/tests/GeniusYield/Test/CoinSelection.hs b/tests/GeniusYield/Test/CoinSelection.hs index f6d76b21..c6eddcad 100644 --- a/tests/GeniusYield/Test/CoinSelection.hs +++ b/tests/GeniusYield/Test/CoinSelection.hs @@ -27,7 +27,7 @@ data CoinSelectionTestParams = CoinSelectionTestParams , cstpOwnUtxos :: [GYValue] -- ^ This shouldn't contain the collateral. } - deriving (Show) + deriving Show prettyTestParams :: CoinSelectionTestParams -> String prettyTestParams CoinSelectionTestParams {..} = @@ -287,11 +287,11 @@ randomImproveTests = testCaseBody expectedAdditionalInps expectedChangeOuts (tokenSalePlaceTestParams 19_902_000_000 rideTheWave) ] ] - where - testCaseBody expectedAdditionalInps expectedChangeOuts params = do - case runCoinSelectionTest GYRandomImproveMultiAsset params of - Left err -> assertFailure $ "Selection failed: " ++ show err - Right x -> (expectedAdditionalInps, expectedChangeOuts) @=? x + where + testCaseBody expectedAdditionalInps expectedChangeOuts params = do + case runCoinSelectionTest GYRandomImproveMultiAsset params of + Left err -> assertFailure $ "Selection failed: " ++ show err + Right x -> (expectedAdditionalInps, expectedChangeOuts) @=? x ------------------------------------------------------------------------------- -- Transaction representing place token sale order @@ -309,10 +309,10 @@ tokenSalePlaceTestParams payment wallet = , cstpTxMint = gyTokenVal , cstpOwnUtxos = wallet } - where - lovelaceAmount = max minLovelace $ valueAssetClass gyTokenVal GYLovelace - minLovelace = toInteger $ mockMinimumUtxo gyTokenVal - gyTokenVal = valueSingleton gyToken 1 + where + lovelaceAmount = max minLovelace $ valueAssetClass gyTokenVal GYLovelace + minLovelace = toInteger $ mockMinimumUtxo gyTokenVal + gyTokenVal = valueSingleton gyToken 1 ------------------------------------------------------------------------------- -- Different mock wallet distributions @@ -403,9 +403,9 @@ runCoinSelectionTest cstrat cstParams = do let inpVals = gyTxInDetValue <$> additionalInps changeVals = gyTxOutValue <$> changeOuts pure (inpVals, changeVals) - where - -- We use a pure StdGen for reproducible tests. - pureStdGen = mkStdGen 936 -- 42 wasn't random enough. + where + -- We use a pure StdGen for reproducible tests. + pureStdGen = mkStdGen 936 -- 42 wasn't random enough. coinSelectionTestParamsToEnv :: CoinSelectionTestParams -> GYCoinSelectionEnv v coinSelectionTestParamsToEnv CoinSelectionTestParams {cstpTxExtInps, cstpTxOwnInps, cstpTxOuts, cstpTxMint, cstpOwnUtxos} = @@ -416,9 +416,9 @@ coinSelectionTestParamsToEnv CoinSelectionTestParams {cstpTxExtInps, cstpTxOwnIn -- (https://github.com/geniusyield/atlas/issues/36) ((mockRecipientAddress,) <$> cstpTxOuts) cstpTxMint - where - ownUtxos = buildOwnUtxos cstpOwnUtxos - inps = buildInps cstpTxExtInps cstpTxOwnInps + where + ownUtxos = buildOwnUtxos cstpOwnUtxos + inps = buildInps cstpTxExtInps cstpTxOwnInps buildEnvWith :: GYUTxOs -> [GYTxInDetailed v] -> [(GYAddress, GYValue)] -> GYValue -> GYCoinSelectionEnv v buildEnvWith ownUtxos existingInps targetOuts mintVal = @@ -437,18 +437,18 @@ buildEnvWith ownUtxos existingInps targetOuts mintVal = buildInps :: [GYValue] -> [GYValue] -> [GYTxInDetailed v] buildInps ext own = go (ext ++ own) - where - go = - zipWith - ( \i v -> - GYTxInDetailed - (GYTxIn (txOutRefFromTuple (mockTxId1, i)) GYTxInWitnessKey) - mockInpAddress - v - GYOutDatumNone - Nothing - ) - [0 ..] + where + go = + zipWith + ( \i v -> + GYTxInDetailed + (GYTxIn (txOutRefFromTuple (mockTxId1, i)) GYTxInWitnessKey) + mockInpAddress + v + GYOutDatumNone + Nothing + ) + [0 ..] buildOwnUtxos :: [GYValue] -> GYUTxOs buildOwnUtxos = @@ -509,13 +509,13 @@ testCaseQuickCheckBody strat prop = forAllShrinkShow genParamsLovelace shrinkPar Right (addInputs, changeOuts) -> monitor (counterexample (getReason addInputs changeOuts)) >> M.assert (prop cstEnv addInputs changeOuts) - where - getReason addInputs changeOuts = - unlines - [ "* AdditionalInputs: " ++ show addInputs - , "* ChangeOuts: " ++ show changeOuts - ] - outputsHaveLovelace env = all (\(_, v) -> valueAssetClass v GYLovelace > 0) (requiredOutputs env) + where + getReason addInputs changeOuts = + unlines + [ "* AdditionalInputs: " ++ show addInputs + , "* ChangeOuts: " ++ show changeOuts + ] + outputsHaveLovelace env = all (\(_, v) -> valueAssetClass v GYLovelace > 0) (requiredOutputs env) propInputsAreSubset :: GYCoinSelectionEnv v -> [GYTxInDetailed v] -> [GYTxOut v] -> Bool propInputsAreSubset env addIns _ = all ((`elem` utxosRefs (ownUtxos env)) . gyTxInTxOutRef . gyTxInDet) addIns @@ -523,18 +523,18 @@ propInputsAreSubset env addIns _ = all ((`elem` utxosRefs (ownUtxos env)) . gyTx propInputsAreEnough :: GYCoinSelectionEnv v -> [GYTxInDetailed v] -> [GYTxOut v] -> Bool propInputsAreEnough env addIns _ = allInputsValue `valueGreaterOrEqual` allOutputsValue - where - allInputsValue = sumEntries (existingInputs env ++ addIns) <> mintValue env - allOutputsValue = mconcat $ map snd (requiredOutputs env) + where + allInputsValue = sumEntries (existingInputs env ++ addIns) <> mintValue env + allOutputsValue = mconcat $ map snd (requiredOutputs env) propChangeIsEnough :: GYCoinSelectionEnv v -> [GYTxInDetailed v] -> [GYTxOut v] -> Bool propChangeIsEnough env addIns changeOuts = changeAssets == txAssets - where - changeValue = mconcat (map gyTxOutValue changeOuts) - changeAssets = snd $ valueSplitAda changeValue - allInputsValue = sumEntries (existingInputs env ++ addIns) <> mintValue env - allOutputsValue = mconcat (map snd (requiredOutputs env)) <> naturalToValue (extraLovelace env) - txAssets = snd $ valueSplitAda $ allInputsValue `valueMinus` allOutputsValue + where + changeValue = mconcat (map gyTxOutValue changeOuts) + changeAssets = snd $ valueSplitAda changeValue + allInputsValue = sumEntries (existingInputs env ++ addIns) <> mintValue env + allOutputsValue = mconcat (map snd (requiredOutputs env)) <> naturalToValue (extraLovelace env) + txAssets = snd $ valueSplitAda $ allInputsValue `valueMinus` allOutputsValue ------------------------------------------------------------------------------- -- QuickCheck Generators @@ -559,41 +559,41 @@ genCoinSelectionParams extraLovelace = do , cstpTxMint = minted , cstpOwnUtxos = ownUtxos } - where - genGYAssetClass :: Gen GYAssetClass - genGYAssetClass = elements $ map mockAsset ["A", "B", "C", "D", "E", "F", "G", "H", "I"] - - genGYValue :: Gen GYValue - genGYValue = oneof [genLovelaceValue, genSingleAssetValue, genAssetValue] - - genLovelaceValue :: Gen GYValue - genLovelaceValue = valueFromLovelace <$> chooseInteger (2_000_000, 200_000_000) - - genSingleAssetValue :: Gen GYValue - genSingleAssetValue = do - lovelaceVal <- genLovelaceValue - assetClass <- genGYAssetClass - amount <- chooseInteger (1, 10_000) - return (lovelaceVal <> valueSingleton assetClass amount) - - genAssetValue :: Gen GYValue - genAssetValue = do - lovelaceVal <- genLovelaceValue - assetClasses <- listOf1 genGYAssetClass - amounts <- vectorOf (length assetClasses) $ chooseInteger (1, 10_000) - return $ lovelaceVal <> valueFromList (zip assetClasses amounts) - - genInputs :: Gen ([GYValue], [GYValue], [GYValue], GYValue) - genInputs = do - extIns <- listOf genGYValue - ownIns <- listOf genGYValue - ownUtxos <- listOf genGYValue - minted <- frequency [(3, genAssetValue), (1, return mempty)] - let assetsMinted = snd $ valueSplitAda minted - return (extIns, ownIns, ownUtxos, assetsMinted) - - genValidInputs :: [GYValue] -> Gen ([GYValue], [GYValue], [GYValue], GYValue) - genValidInputs outs = genInputs `suchThat` inputsAreValid outs extraLovelace + where + genGYAssetClass :: Gen GYAssetClass + genGYAssetClass = elements $ map mockAsset ["A", "B", "C", "D", "E", "F", "G", "H", "I"] + + genGYValue :: Gen GYValue + genGYValue = oneof [genLovelaceValue, genSingleAssetValue, genAssetValue] + + genLovelaceValue :: Gen GYValue + genLovelaceValue = valueFromLovelace <$> chooseInteger (2_000_000, 200_000_000) + + genSingleAssetValue :: Gen GYValue + genSingleAssetValue = do + lovelaceVal <- genLovelaceValue + assetClass <- genGYAssetClass + amount <- chooseInteger (1, 10_000) + return (lovelaceVal <> valueSingleton assetClass amount) + + genAssetValue :: Gen GYValue + genAssetValue = do + lovelaceVal <- genLovelaceValue + assetClasses <- listOf1 genGYAssetClass + amounts <- vectorOf (length assetClasses) $ chooseInteger (1, 10_000) + return $ lovelaceVal <> valueFromList (zip assetClasses amounts) + + genInputs :: Gen ([GYValue], [GYValue], [GYValue], GYValue) + genInputs = do + extIns <- listOf genGYValue + ownIns <- listOf genGYValue + ownUtxos <- listOf genGYValue + minted <- frequency [(3, genAssetValue), (1, return mempty)] + let assetsMinted = snd $ valueSplitAda minted + return (extIns, ownIns, ownUtxos, assetsMinted) + + genValidInputs :: [GYValue] -> Gen ([GYValue], [GYValue], [GYValue], GYValue) + genValidInputs outs = genInputs `suchThat` inputsAreValid outs extraLovelace genParamsLovelace :: Gen (CoinSelectionTestParams, Natural) genParamsLovelace = do diff --git a/tests/GeniusYield/Test/GYTxBody.hs b/tests/GeniusYield/Test/GYTxBody.hs index e01b18c0..61e049d2 100644 --- a/tests/GeniusYield/Test/GYTxBody.hs +++ b/tests/GeniusYield/Test/GYTxBody.hs @@ -128,19 +128,19 @@ adjustTxTests = ] val `adjustedShouldEqual` (val <> valueFromLovelace 1_184_380) ] - where - mockAdjust :: GYTxOut v -> GYTxOut v - mockAdjust = adjustTxOut mockMinimumUTxO + where + mockAdjust :: GYTxOut v -> GYTxOut v + mockAdjust = adjustTxOut mockMinimumUTxO - mockMinimumUTxO :: GYTxOut v -> Natural - mockMinimumUTxO = minimumUTxO mockProtocolParams + mockMinimumUTxO :: GYTxOut v -> Natural + mockMinimumUTxO = minimumUTxO mockProtocolParams - lovelacesAdjustedShouldEqual :: Integer -> Integer -> Assertion - lovelacesAdjustedShouldEqual n m = - mockAdjust (mockTxOutFromLovelace n) @?= mockTxOutFromLovelace m + lovelacesAdjustedShouldEqual :: Integer -> Integer -> Assertion + lovelacesAdjustedShouldEqual n m = + mockAdjust (mockTxOutFromLovelace n) @?= mockTxOutFromLovelace m - adjustedShouldEqual :: GYValue -> GYValue -> Assertion - adjustedShouldEqual v1 v2 = mockAdjust (mockTxOut v1) @?= mockTxOut v2 + adjustedShouldEqual :: GYValue -> GYValue -> Assertion + adjustedShouldEqual v1 v2 = mockAdjust (mockTxOut v1) @?= mockTxOut v2 balanceTxStepTests :: [TestTree] balanceTxStepTests = @@ -231,14 +231,14 @@ mockBuildTxEnv wallet = , gyBTxEnvChangeAddr = mockChangeAddress , gyBTxEnvCollateral = collateralUtxo } - where - slotLen = fromInteger (scSlotLength defaultSlotConfig) / 1000 - slotZero = - posixSecondsToUTCTime $ - timeToPOSIX $ - timeFromPlutus $ - scSlotZeroTime defaultSlotConfig - mockSystemStart = gyscSystemStart $ simpleSlotConfig slotZero slotLen + where + slotLen = fromInteger (scSlotLength defaultSlotConfig) / 1000 + slotZero = + posixSecondsToUTCTime $ + timeToPOSIX $ + timeFromPlutus $ + scSlotZeroTime defaultSlotConfig + mockSystemStart = gyscSystemStart $ simpleSlotConfig slotZero slotLen buildOwnUtxos :: [GYValue] -> GYUTxOs buildOwnUtxos = diff --git a/tests/GeniusYield/Test/GYTxSkeleton.hs b/tests/GeniusYield/Test/GYTxSkeleton.hs index 10c9aa79..bb39d20b 100644 --- a/tests/GeniusYield/Test/GYTxSkeleton.hs +++ b/tests/GeniusYield/Test/GYTxSkeleton.hs @@ -243,13 +243,13 @@ mockTxOut2 = mkGYTxOutNoDatum mockOutAddress (mockOutValue <> mockOutValue) mockPkh1 :: GYPubKeyHash mockPkh1 = fromRight err $ pubKeyHashFromPlutus "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" - where - err = error "absurd" + where + err = error "absurd" mockPkh2 :: GYPubKeyHash mockPkh2 = fromRight err $ pubKeyHashFromPlutus "69aeb93ec15eb963dda5176b66949fe1c2a6a38de1cbb80db89e2922" - where - err = error "absurd" + where + err = error "absurd" mockSlot :: GYSlot mockSlot = mockSlot' 1000 diff --git a/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs b/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs index d927d035..c4d44218 100644 --- a/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs +++ b/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs @@ -32,31 +32,31 @@ mkGuessRefInputDatumValidator :: BuiltinData -> BuiltinData -> BuiltinData -> () mkGuessRefInputDatumValidator _ red' ctx' | guess == original = () | otherwise = error () - where - ctx :: ScriptContext - ctx = unsafeFromBuiltinData ctx' - - Guess guess = unsafeFromBuiltinData red' - - info :: TxInfo - info = scriptContextTxInfo ctx - - refIn :: TxOut - refIn = case map txInInfoResolved (txInfoReferenceInputs info) of - [refIn'] -> refIn' - [] -> traceError "No reference input provided." - _anyOther -> traceError "Expected only one reference input but found more than one." - - outputToDatum :: (FromData b) => TxOut -> Maybe b - outputToDatum o = case txOutDatum o of - NoOutputDatum -> Nothing - OutputDatum d -> processDatum d - OutputDatumHash dh -> processDatum =<< findDatum dh info - where - processDatum = fromBuiltinData . getDatum - - original :: Integer - original = - case outputToDatum refIn of - Nothing -> traceError "Datum not present or parsed." - Just (RefInputDatum original') -> original' + where + ctx :: ScriptContext + ctx = unsafeFromBuiltinData ctx' + + Guess guess = unsafeFromBuiltinData red' + + info :: TxInfo + info = scriptContextTxInfo ctx + + refIn :: TxOut + refIn = case map txInInfoResolved (txInfoReferenceInputs info) of + [refIn'] -> refIn' + [] -> traceError "No reference input provided." + _anyOther -> traceError "Expected only one reference input but found more than one." + + outputToDatum :: FromData b => TxOut -> Maybe b + outputToDatum o = case txOutDatum o of + NoOutputDatum -> Nothing + OutputDatum d -> processDatum d + OutputDatumHash dh -> processDatum =<< findDatum dh info + where + processDatum = fromBuiltinData . getDatum + + original :: Integer + original = + case outputToDatum refIn of + Nothing -> traceError "Datum not present or parsed." + Just (RefInputDatum original') -> original' diff --git a/tests/GeniusYield/Test/Providers.hs b/tests/GeniusYield/Test/Providers.hs index 448e9d0c..3d4bd03b 100644 --- a/tests/GeniusYield/Test/Providers.hs +++ b/tests/GeniusYield/Test/Providers.hs @@ -205,74 +205,74 @@ maestroTests token netId = res @?= expected ] ] - where - getQueryUtxo :: Text.Text -> IO GYQueryUTxO - getQueryUtxo pToken = maestroQueryUtxo <$> networkIdToMaestroEnv pToken netId - - getUTxOsAtAddress :: GYAddress -> Text.Text -> IO (Api.UTxO ApiEra) - getUTxOsAtAddress addr pToken = do - queryUtxo <- getQueryUtxo pToken - utxos <- gyQueryUtxosAtAddress' queryUtxo addr Nothing - return $ utxosToApi utxos - - getUTxOsAtAddresses :: [GYAddress] -> Text.Text -> IO (Api.UTxO ApiEra) - getUTxOsAtAddresses addrs pToken = do - queryUtxo <- getQueryUtxo pToken - utxos <- gyQueryUtxosAtAddresses' queryUtxo addrs - return $ utxosToApi utxos - - getUTxOAtRef :: GYTxOutRef -> Text.Text -> IO (Api.UTxO ApiEra) - getUTxOAtRef ref pToken = do - queryUtxo <- getQueryUtxo pToken - utxo <- gyQueryUtxoAtTxOutRef' queryUtxo ref - return $ utxosToApi $ utxosFromList [fromJust utxo] - - getUTxOsRefsAtAddress :: GYAddress -> Text.Text -> IO [GYTxOutRef] - getUTxOsRefsAtAddress addr pToken = do - queryUtxo <- getQueryUtxo pToken - gyQueryUtxoRefsAtAddress' queryUtxo addr - - getFileRefs :: String -> IO [GYTxOutRef] - getFileRefs fileName = do - json <- BS.readFile fileName - let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) - refs = utxosRefs $ utxosFromApi utxos - return refs - - getFileUTxOs :: String -> IO (Api.UTxO ApiEra) - getFileUTxOs fileName = do - json <- BS.readFile fileName - let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) - return utxos - - compareUTxOs :: Api.UTxO ApiEra -> Api.UTxO ApiEra -> IO (Maybe String) - compareUTxOs utxosFile utxosQuery = do - let utxosFileMap = Api.unUTxO utxosFile - utxosQueryMap = Api.unUTxO utxosQuery - return $ - if Map.isSubmapOf utxosFileMap utxosQueryMap - then Nothing - else Just $ show (Map.difference utxosFileMap utxosQueryMap) - - compareRefs :: [GYTxOutRef] -> [GYTxOutRef] -> IO (Maybe String) - compareRefs refsFile refsQuery = do - let refSetQuery = Set.fromList refsQuery - refSetFile = Set.fromList refsFile - return $ - if Set.isSubsetOf refSetFile refSetQuery - then Nothing - else Just $ show (Set.difference refSetFile refSetQuery) - - updateGolden :: (Show a) => a -> IO () - updateGolden = error . show - - goldenTestUtxos :: TestName -> IO (Api.UTxO ApiEra) -> IO (Api.UTxO ApiEra) -> TestTree - goldenTestUtxos name queryData getFileData = - goldenTest name queryData getFileData compareUTxOs updateGolden - - goldenTestRefs :: TestName -> IO [GYTxOutRef] -> IO [GYTxOutRef] -> TestTree - goldenTestRefs name queryData getFileData = - goldenTest name queryData getFileData compareRefs updateGolden + where + getQueryUtxo :: Text.Text -> IO GYQueryUTxO + getQueryUtxo pToken = maestroQueryUtxo <$> networkIdToMaestroEnv pToken netId + + getUTxOsAtAddress :: GYAddress -> Text.Text -> IO (Api.UTxO ApiEra) + getUTxOsAtAddress addr pToken = do + queryUtxo <- getQueryUtxo pToken + utxos <- gyQueryUtxosAtAddress' queryUtxo addr Nothing + return $ utxosToApi utxos + + getUTxOsAtAddresses :: [GYAddress] -> Text.Text -> IO (Api.UTxO ApiEra) + getUTxOsAtAddresses addrs pToken = do + queryUtxo <- getQueryUtxo pToken + utxos <- gyQueryUtxosAtAddresses' queryUtxo addrs + return $ utxosToApi utxos + + getUTxOAtRef :: GYTxOutRef -> Text.Text -> IO (Api.UTxO ApiEra) + getUTxOAtRef ref pToken = do + queryUtxo <- getQueryUtxo pToken + utxo <- gyQueryUtxoAtTxOutRef' queryUtxo ref + return $ utxosToApi $ utxosFromList [fromJust utxo] + + getUTxOsRefsAtAddress :: GYAddress -> Text.Text -> IO [GYTxOutRef] + getUTxOsRefsAtAddress addr pToken = do + queryUtxo <- getQueryUtxo pToken + gyQueryUtxoRefsAtAddress' queryUtxo addr + + getFileRefs :: String -> IO [GYTxOutRef] + getFileRefs fileName = do + json <- BS.readFile fileName + let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) + refs = utxosRefs $ utxosFromApi utxos + return refs + + getFileUTxOs :: String -> IO (Api.UTxO ApiEra) + getFileUTxOs fileName = do + json <- BS.readFile fileName + let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) + return utxos + + compareUTxOs :: Api.UTxO ApiEra -> Api.UTxO ApiEra -> IO (Maybe String) + compareUTxOs utxosFile utxosQuery = do + let utxosFileMap = Api.unUTxO utxosFile + utxosQueryMap = Api.unUTxO utxosQuery + return $ + if Map.isSubmapOf utxosFileMap utxosQueryMap + then Nothing + else Just $ show (Map.difference utxosFileMap utxosQueryMap) + + compareRefs :: [GYTxOutRef] -> [GYTxOutRef] -> IO (Maybe String) + compareRefs refsFile refsQuery = do + let refSetQuery = Set.fromList refsQuery + refSetFile = Set.fromList refsFile + return $ + if Set.isSubsetOf refSetFile refSetQuery + then Nothing + else Just $ show (Set.difference refSetFile refSetQuery) + + updateGolden :: Show a => a -> IO () + updateGolden = error . show + + goldenTestUtxos :: TestName -> IO (Api.UTxO ApiEra) -> IO (Api.UTxO ApiEra) -> TestTree + goldenTestUtxos name queryData getFileData = + goldenTest name queryData getFileData compareUTxOs updateGolden + + goldenTestRefs :: TestName -> IO [GYTxOutRef] -> IO [GYTxOutRef] -> TestTree + goldenTestRefs name queryData getFileData = + goldenTest name queryData getFileData compareRefs updateGolden ------------------------------------------------------------------------------- -- Mock Values diff --git a/tests/GeniusYield/Test/Providers/Mashup.hs b/tests/GeniusYield/Test/Providers/Mashup.hs index 5c9cefa9..f7f24a03 100644 --- a/tests/GeniusYield/Test/Providers/Mashup.hs +++ b/tests/GeniusYield/Test/Providers/Mashup.hs @@ -159,9 +159,9 @@ providersMashupTests configs = gyAwaitTxConfirmed def {maxAttempts = 2, checkInterval = 1_000_000} "9b50152cc5cfca6a842f32b1e886a3ffdc1a1704fa87a15a88837996b6a9df36" -- <-- A non-existing transaction id. assertFailure "Exepected GYAwaitTxException to be raised" ] - where - delayBySecond = threadDelay 1_000_000 + where + delayBySecond = threadDelay 1_000_000 -allEqual :: (Eq a) => [a] -> Bool +allEqual :: Eq a => [a] -> Bool allEqual [] = True allEqual (x : xs) = all (== x) xs diff --git a/tests/GeniusYield/Test/RefInput.hs b/tests/GeniusYield/Test/RefInput.hs index 166c06aa..244ed563 100644 --- a/tests/GeniusYield/Test/RefInput.hs +++ b/tests/GeniusYield/Test/RefInput.hs @@ -43,7 +43,7 @@ refInputTests = . testWallets ] -guessRefInputRun :: (GYTxMonad m) => GYTxOutRef -> GYTxOutRef -> Integer -> m () +guessRefInputRun :: GYTxMonad m => GYTxOutRef -> GYTxOutRef -> Integer -> m () guessRefInputRun refInputORef consumeRef guess = do let redeemer = Guess guess skeleton :: GYTxSkeleton 'PlutusV2 = @@ -59,7 +59,7 @@ guessRefInputRun refInputORef consumeRef guess = do <> mustHaveRefInput refInputORef buildTxBody skeleton >>= signAndSubmitConfirmed_ -refInputTrace :: (GYTxGameMonad m) => Bool -> Integer -> Integer -> Wallets -> m () +refInputTrace :: GYTxGameMonad m => Bool -> Integer -> Integer -> Wallets -> m () refInputTrace toInline actual guess Wallets {..} = do let myGuess :: Integer = guess outValue :: GYValue = valueFromLovelace 20_000_000 @@ -78,7 +78,7 @@ refInputTrace toInline actual guess Wallets {..} = do gyLogInfo' "" $ printf "Locked ORef %s" oref guessRefInputRun refInputORef oref myGuess -tryRefInputConsume :: (GYTxGameMonad m) => Wallets -> m () +tryRefInputConsume :: GYTxGameMonad m => Wallets -> m () tryRefInputConsume Wallets {..} = do -- Approach: Create a new output with 60% of total ada. Mark this UTxO as reference input and try sending this same 60%, or any amount greater than 40% of this original balance. Since coin balancer can't consume this UTxO, it won't be able to build for it. asUser w1 $ do diff --git a/tests/GeniusYield/Test/SlotConfig.hs b/tests/GeniusYield/Test/SlotConfig.hs index 4ad8e652..5090291a 100644 --- a/tests/GeniusYield/Test/SlotConfig.hs +++ b/tests/GeniusYield/Test/SlotConfig.hs @@ -21,16 +21,16 @@ import GeniusYield.Types slotToTime :: forall xs. Ouroboros.SystemStart -> Ouroboros.Interpreter xs -> Api.SlotNo -> Either String UTCTime slotToTime systemStart eraHistory x = bimap show (Ouroboros.fromRelativeTime systemStart) res - where - res = Ouroboros.interpretQuery eraHistory $ fst <$> Ouroboros.slotToWallclock x + where + res = Ouroboros.interpretQuery eraHistory $ fst <$> Ouroboros.slotToWallclock x timeToSlot :: forall xs. Ouroboros.SystemStart -> Ouroboros.Interpreter xs -> UTCTime -> Either String Api.SlotNo timeToSlot systemStart eraHistory utc = first show res - where - res = - Ouroboros.interpretQuery eraHistory $ - (\(slot, _, _) -> slot) - <$> Ouroboros.wallclockToSlot (Ouroboros.toRelativeTime systemStart utc) + where + res = + Ouroboros.interpretQuery eraHistory $ + (\(slot, _, _) -> slot) + <$> Ouroboros.wallclockToSlot (Ouroboros.toRelativeTime systemStart utc) checkTimeToSlot :: Api.EraHistory -> Property checkTimeToSlot eraHistory = @@ -44,9 +44,9 @@ checkTimeToSlot eraHistory = let actualRes = enclosingSlotFromTimePure slotCfg $ timeFromPOSIX (utcTimeToPOSIXSeconds utc) pure $ Just expected == (slotToApi <$> actualRes) - where - summaries = extractEraSummaries eraHistory - (_, eraEnd) = Ouroboros.summaryBounds summaries + where + summaries = extractEraSummaries eraHistory + (_, eraEnd) = Ouroboros.summaryBounds summaries checkSlotToTime :: Api.EraHistory -> Property checkSlotToTime eraHistory = @@ -60,9 +60,9 @@ checkSlotToTime eraHistory = slotCfg <- makeSlotConfig systemStart eraHistory let actualRes = posixSecondsToUTCTime (timeToPOSIX $ slotToBeginTimePure slotCfg gslot) pure $ expectedRes === actualRes - where - summaries = extractEraSummaries eraHistory - (_, eraEnd) = Ouroboros.summaryBounds summaries + where + summaries = extractEraSummaries eraHistory + (_, eraEnd) = Ouroboros.summaryBounds summaries slotConversionTests :: TestTree slotConversionTests = @@ -87,11 +87,11 @@ slotConversionTests = -- | Greater than or equal to system start, less than or equal to final era bound. arbitraryTimeInRange :: Ouroboros.SystemStart -> Ouroboros.EraEnd -> Gen UTCTime arbitraryTimeInRange sysStart eraEnd = arbitrary `suchThat` (\x -> x >= absStart && ltEnd x) - where - absStart = Ouroboros.getSystemStart sysStart - ltEnd x = case eraEnd of - Ouroboros.EraEnd bo -> x < Ouroboros.fromRelativeTime sysStart (Ouroboros.boundTime bo) - Ouroboros.EraUnbounded -> True + where + absStart = Ouroboros.getSystemStart sysStart + ltEnd x = case eraEnd of + Ouroboros.EraEnd bo -> x < Ouroboros.fromRelativeTime sysStart (Ouroboros.boundTime bo) + Ouroboros.EraUnbounded -> True -- | Generate an arbitrary slot before given era end. arbitrarySlotBefore :: Ouroboros.EraEnd -> Gen Api.SlotNo From 6170595898120e620656ed5bd8475a85cc172000 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Thu, 5 Sep 2024 21:13:43 +0530 Subject: [PATCH 5/9] ci(#348): move fourmolu installation after cabal update has been performed --- .github/workflows/haskell.yml | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index f819e03c..cc01643b 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -119,12 +119,6 @@ jobs: ${{ runner.os }}-build- ${{ runner.os }}- - - name: Install fourmolu - run: cabal install fourmolu --overwrite-policy=always - - - name: Run checks (fourmolu) - run: git ls-files -z '*.hs' | xargs -P 12 -0 fourmolu --mode check - - name: Install LIBSODIUM run: | git clone https://github.com/input-output-hk/libsodium @@ -174,6 +168,10 @@ jobs: run: cabal build --only-dependencies --enable-tests --enable-benchmarks - name: Build all targets (cabal) run: cabal build --enable-tests --enable-benchmarks all + - name: Install fourmolu + run: cabal install fourmolu --overwrite-policy=always + - name: Run checks (fourmolu) + run: git ls-files -z '*.hs' | xargs -P 12 -0 fourmolu --mode check - name: Symlink cardano-node binaries run: cabal install --package-env=$(pwd) --overwrite-policy=always cardano-cli cardano-node - name: Run privnet tests From 93341779e11d130f6abe141e24416b51f7e87cb3 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Fri, 6 Sep 2024 12:14:56 +0530 Subject: [PATCH 6/9] feat(#348): handle formatting of merged files --- src/GeniusYield/Test/Utils.hs | 3 +- .../Test/Unified/BetRef/Operations.hs | 84 ++-- .../Test/Unified/BetRef/PlaceBet.hs | 400 ++++++++++-------- .../Test/Unified/BetRef/TakePot.hs | 166 +++++--- .../Test/Unified/OnChain/BetRef.hs | 3 +- tests-unified/atlas-unified-tests.hs | 21 +- 6 files changed, 389 insertions(+), 288 deletions(-) diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index 932b49f7..be1926c1 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -116,7 +116,8 @@ TL;DR: Remove all user creation code from test setups and point Atlas users to u data TestInfo = TestInfo { testGoldAsset :: !GYAssetClass , testIronAsset :: !GYAssetClass - , testWallets :: !Wallets } + , testWallets :: !Wallets + } -- TODO (simplify-genesis): Remove this type once user creation logic is removed from test setup. diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs index ecd3b35a..63b53c5c 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs @@ -1,10 +1,10 @@ -module GeniusYield.Test.Unified.BetRef.Operations - ( mkScript - , mkBetRefValidator - , betRefAddress - , placeBet - , takeBets - ) where +module GeniusYield.Test.Unified.BetRef.Operations ( + mkScript, + mkBetRefValidator, + betRefAddress, + placeBet, + takeBets, +) where import GeniusYield.Imports import GeniusYield.TxBuilder @@ -12,15 +12,20 @@ import GeniusYield.Types import GeniusYield.Test.Unified.OnChain.BetRef.Compiled --- | Queries the cuurent slot, calculates parameters and builds --- a script that is ready to be deployed. -mkScript - :: GYTxQueryMonad m - => Integer -- ^ How many slots betting should be open - -> Integer -- ^ How many slots should pass before oracle reveals answer - -> GYPubKeyHash -- ^ Oracle PKH - -> GYValue -- ^ Bet step value - -> m (BetRefParams, GYScript PlutusV2) +{- | Queries the cuurent slot, calculates parameters and builds +a script that is ready to be deployed. +-} +mkScript :: + GYTxQueryMonad m => + -- | How many slots betting should be open + Integer -> + -- | How many slots should pass before oracle reveals answer + Integer -> + -- | Oracle PKH + GYPubKeyHash -> + -- | Bet step value + GYValue -> + m (BetRefParams, GYScript PlutusV2) mkScript betUntil betReveal oraclePkh betStep = do currSlot <- slotToInteger <$> slotOfCurrentBlock -- Calculate params for the script @@ -28,11 +33,12 @@ mkScript betUntil betReveal oraclePkh betStep = do let betReveal' = slotFromApi $ fromInteger $ currSlot + betReveal betUntilTime <- slotToBeginTime betUntil' betRevealTime <- slotToBeginTime betReveal' - let params = BetRefParams - (pubKeyHashToPlutus oraclePkh) - (timeToPlutus betUntilTime) - (timeToPlutus betRevealTime) - (valueToPlutus betStep) + let params = + BetRefParams + (pubKeyHashToPlutus oraclePkh) + (timeToPlutus betUntilTime) + (timeToPlutus betRevealTime) + (valueToPlutus betStep) gyLogDebug' "" $ printf "Parameters: %s" (show params) pure (params, validatorToScript $ mkBetRefValidator params) @@ -102,13 +108,19 @@ placeBet refScript brp guess bet ownAddr mPreviousBetsUtxoRef = do <> mustBeSignedBy pkh -- | Operation to take UTxO corresponding to previous bets. -takeBets :: (HasCallStack, GYTxQueryMonad m) - => GYTxOutRef -- ^ Reference Script. - -> BetRefParams -- ^ Validator params. - -> GYTxOutRef -- ^ Script UTxO to consume. - -> GYAddress -- ^ Own address. - -> GYTxOutRef -- ^ Oracle reference input. - -> m (GYTxSkeleton 'PlutusV2) +takeBets :: + (HasCallStack, GYTxQueryMonad m) => + -- | Reference Script. + GYTxOutRef -> + -- | Validator params. + BetRefParams -> + -- | Script UTxO to consume. + GYTxOutRef -> + -- | Own address. + GYAddress -> + -- | Oracle reference input. + GYTxOutRef -> + m (GYTxSkeleton 'PlutusV2) takeBets refScript brp previousBetsUtxoRef ownAddr oracleRefInput = do pkh <- addressToPubKeyHash' ownAddr previousUtxo <- utxoAtTxOutRef' previousBetsUtxoRef @@ -123,10 +135,12 @@ takeBets refScript brp previousBetsUtxoRef ownAddr oracleRefInput = do -- | Utility function to consume script UTxO. input :: BetRefParams -> GYTxOutRef -> GYTxOutRef -> BetRefDatum -> BetRefAction -> GYTxSkeleton 'PlutusV2 input brp refScript inputRef dat red = - mustHaveInput GYTxIn - { gyTxInTxOutRef = inputRef - , gyTxInWitness = GYTxInWitnessScript - (GYInReference refScript $ validatorToScript $ mkBetRefValidator brp) - (datumFromPlutusData dat) - (redeemerFromPlutusData red) - } + mustHaveInput + GYTxIn + { gyTxInTxOutRef = inputRef + , gyTxInWitness = + GYTxInWitnessScript + (GYInReference refScript $ validatorToScript $ mkBetRefValidator brp) + (datumFromPlutusData dat) + (redeemerFromPlutusData red) + } diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index 72e09f39..f88f5c4d 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -1,44 +1,44 @@ -module GeniusYield.Test.Unified.BetRef.PlaceBet - ( placeBetTests - , placeBetTestsClb - , runDeployScript - , runMultipleBets - , Bet - ) where +module GeniusYield.Test.Unified.BetRef.PlaceBet ( + placeBetTests, + placeBetTestsClb, + runDeployScript, + runMultipleBets, + Bet, +) where -import Control.Monad.Except (handleError) -import Control.Monad.Extra (maybeM) -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Maybe (listToMaybe) -import Test.Tasty (TestTree, - testGroup) +import Control.Monad.Except (handleError) +import Control.Monad.Extra (maybeM) +import Data.Maybe (listToMaybe) +import Data.Set qualified as Set +import Data.Text qualified as T +import Test.Tasty ( + TestTree, + testGroup, + ) +import GeniusYield.HTTP.Errors +import GeniusYield.Imports +import GeniusYield.Test.Clb +import GeniusYield.Test.Privnet.Setup import GeniusYield.Test.Unified.BetRef.Operations import GeniusYield.Test.Unified.OnChain.BetRef.Compiled +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types -import GeniusYield.Test.Unified.BetRef.Operations -import GeniusYield.Test.Unified.OnChain.BetRef.Compiled -import GeniusYield.Imports -import GeniusYield.HTTP.Errors -import GeniusYield.Imports -import GeniusYield.Test.Clb -import GeniusYield.Test.Privnet.Setup -import GeniusYield.Test.Utils -import GeniusYield.TxBuilder -import GeniusYield.Types - - --- | Test environment 'WalletInfo' among other things provides nine wallets that --- be used in tests. For convinience we assign some meaningful names to them. +{- | Test environment 'WalletInfo' among other things provides nine wallets that +be used in tests. For convinience we assign some meaningful names to them. +-} admin, oracle, holder :: Wallets -> User -admin = w1 -- Runs some administrative action, e.g. deplys the script +admin = w1 -- Runs some administrative action, e.g. deplys the script oracle = w8 -- A user that is going to reveal the answer holder = w9 -- A user to store the reference script -- | Test suite for the emulator placeBetTestsClb :: TestTree -placeBetTestsClb = testGroup "Place bet" +placeBetTestsClb = + testGroup + "Place bet" [ mkTestFor "Simple tx" $ simpleTxTest , mkTestFor "Placing first bet" firstBetTest' , mkTestFor "Multiple bets" multipleBetsTest @@ -47,7 +47,9 @@ placeBetTestsClb = testGroup "Place bet" -- | Test suite for a private testnet placeBetTests :: Setup -> TestTree -placeBetTests setup = testGroup "Place bet" +placeBetTests setup = + testGroup + "Place bet" [ mkPrivnetTestFor_ "Simple tx" $ simpleTxTest , mkPrivnetTestFor_ "Placing first bet" firstBetTest' , mkPrivnetTestFor_ "Multiple bets" multipleBetsTest @@ -59,29 +61,34 @@ placeBetTests setup = testGroup "Place bet" ) . failingMultipleBetsTest ] - where - mkPrivnetTestFor_ = flip mkPrivnetTestFor setup + where + mkPrivnetTestFor_ = flip mkPrivnetTestFor setup -- ----------------------------------------------------------------------------- -- Simple tx -- ----------------------------------------------------------------------------- --- | Trace for a super-simple spending transaction. This function combines --- the runner and the test for simplicity's sake. +{- | Trace for a super-simple spending transaction. This function combines +the runner and the test for simplicity's sake. +-} simpleTxTest :: GYTxGameMonad m => TestInfo -> m () -simpleTxTest (testWallets -> Wallets{w1}) = do - withWalletBalancesCheckSimple [w1 := valueFromLovelace (-100_000_000)] . - asUser w1 $ do - skeleton <- mkTrivialTx - gyLogDebug' "" $ printf "tx skeleton: %s" (show skeleton) - txId <- buildTxBody skeleton >>= signAndSubmitConfirmed - gyLogDebug' "" $ printf "tx submitted, txId: %s" txId +simpleTxTest (testWallets -> Wallets {w1}) = do + withWalletBalancesCheckSimple [w1 := valueFromLovelace (-100_000_000)] + . asUser w1 + $ do + skeleton <- mkTrivialTx + gyLogDebug' "" $ printf "tx skeleton: %s" (show skeleton) + txId <- buildTxBody skeleton >>= signAndSubmitConfirmed + gyLogDebug' "" $ printf "tx submitted, txId: %s" txId -- Pretend off-chain code written in 'GYTxUserQueryMonad m' mkTrivialTx :: GYTxUserQueryMonad m => m (GYTxSkeleton 'PlutusV2) mkTrivialTx = do - addr <- maybeM (throwAppError $ someBackendError "No own addresses") - pure $ listToMaybe <$> ownAddresses + addr <- + maybeM + (throwAppError $ someBackendError "No own addresses") + pure + $ listToMaybe <$> ownAddresses gyLogDebug' "" $ printf "ownAddr: %s" (show addr) pkh <- addressToPubKeyHash' addr let targetAddr = unsafeAddressFromText "addr_test1qr2vfntpz92f9pawk8gs0fdmhtfe32pqcx0s8fuztxaw3p5pjay24kygaj4g8uevf89ewxzvsdc60wln8spzm2al059q8a9w3x" @@ -101,45 +108,57 @@ mkTrivialTx = do -- ----------------------------------------------------------------------------- -- | Run to call the `placeBet` operation. -runPlaceBet - :: GYTxGameMonad m - => GYTxOutRef -- ^ Script output reference - -> BetRefParams -- ^ Parameters - -> OracleAnswerDatum -- ^ Bet guess - -> GYValue -- ^ Bet value - -> Maybe GYTxOutRef -- ^ Ref output with existing bets - -> User -- ^ User that plays bet - -> m GYTxId +runPlaceBet :: + GYTxGameMonad m => + -- | Script output reference + GYTxOutRef -> + -- | Parameters + BetRefParams -> + -- | Bet guess + OracleAnswerDatum -> + -- | Bet value + GYValue -> + -- | Ref output with existing bets + Maybe GYTxOutRef -> + -- | User that plays bet + User -> + m GYTxId runPlaceBet refScript brp guess bet mPrevBets user = do - gyLogDebug' "" - $ printf "placing a bet with guess %s and value %s" - (show guess) (show bet) + gyLogDebug' "" $ + printf + "placing a bet with guess %s and value %s" + (show guess) + (show bet) asUser user $ do - addr <- maybeM (throwAppError $ someBackendError "No own addresses") - pure $ listToMaybe <$> ownAddresses + addr <- + maybeM + (throwAppError $ someBackendError "No own addresses") + pure + $ listToMaybe <$> ownAddresses -- Call the operation skeleton <- placeBet refScript brp guess bet addr mPrevBets buildTxBody skeleton >>= signAndSubmitConfirmed firstBetTest' :: GYTxGameMonad m => TestInfo -> m () -firstBetTest' = firstBetTest - 40 - 100 - (valueFromLovelace 200_000_000) - (OracleAnswerDatum 3) - (valueFromLovelace 20_000_000) +firstBetTest' = + firstBetTest + 40 + 100 + (valueFromLovelace 200_000_000) + (OracleAnswerDatum 3) + (valueFromLovelace 20_000_000) -- | Test for placing the first bet. -firstBetTest - :: GYTxGameMonad m - => Integer - -> Integer - -> GYValue - -> OracleAnswerDatum - -> GYValue - -> TestInfo - -> m () -firstBetTest betUntil betReveal betStep dat bet (testWallets -> ws@Wallets{w1}) = do +firstBetTest :: + GYTxGameMonad m => + Integer -> + Integer -> + GYValue -> + OracleAnswerDatum -> + GYValue -> + TestInfo -> + m () +firstBetTest betUntil betReveal betStep dat bet (testWallets -> ws@Wallets {w1}) = do (brp, refScript) <- runDeployScript betUntil betReveal betStep ws withWalletBalancesCheckSimple [w1 := valueNegate bet] $ do void $ runPlaceBet refScript brp dat bet Nothing w1 @@ -155,38 +174,57 @@ type Wallet = Wallets -> User type Bet = (Wallet, OracleAnswerDatum, GYValue) multipleBetsTest :: GYTxGameMonad m => TestInfo -> m () -multipleBetsTest TestInfo{..} = mkMultipleBetsTest - 400 1_000 (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 - <> valueSingleton testGoldAsset 1_000) - ] - testWallets +multipleBetsTest TestInfo {..} = + mkMultipleBetsTest + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , + ( w4 + , OracleAnswerDatum 5 + , valueFromLovelace 65_000_000 + <> valueSingleton testGoldAsset 1_000 + ) + ] + testWallets failingMultipleBetsTest :: GYTxGameMonad m => TestInfo -> m () -failingMultipleBetsTest TestInfo{..} = mkMultipleBetsTest - 400 1_000 (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 55_000_000 - <> valueSingleton testGoldAsset 1_000) - ] - testWallets +failingMultipleBetsTest TestInfo {..} = + mkMultipleBetsTest + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , + ( w4 + , OracleAnswerDatum 5 + , valueFromLovelace 55_000_000 + <> valueSingleton testGoldAsset 1_000 + ) + ] + testWallets -- | Makes a test case for placing multiple bets. -mkMultipleBetsTest - :: GYTxGameMonad m - => Integer -- ^ Number of slots for betting - -> Integer -- ^ Number of slots for revealing - -> GYValue -- ^ Bet step - -> [Bet] -- ^ List denoting the bets - -> Wallets -- ^ Wallets available - -> m () +mkMultipleBetsTest :: + GYTxGameMonad m => + -- | Number of slots for betting + Integer -> + -- | Number of slots for revealing + Integer -> + -- | Bet step + GYValue -> + -- | List denoting the bets + [Bet] -> + -- | Wallets available + Wallets -> + m () mkMultipleBetsTest betUntil betReveal betStep bets ws = do -- Deploy script (brp, refScript) <- runDeployScript betUntil betReveal betStep ws @@ -199,82 +237,85 @@ mkMultipleBetsTest betUntil betReveal betStep bets ws = do balanceAfter <- getBalance gyLogDebug' "" $ printf "balanceAfterAllTheseOps: %s" (mconcat balanceAfter) -- Check the difference - verify $ zip3 - walletsAndBets - balanceBefore - balanceAfter - where - -- | Returns the balances for all wallets that play the game - getBalance :: GYTxGameMonad m => m [GYValue] - getBalance = traverse + verify $ + zip3 + walletsAndBets + balanceBefore + balanceAfter + where + -- \| Returns the balances for all wallets that play the game + getBalance :: GYTxGameMonad m => m [GYValue] + getBalance = + traverse (\(wallet, _) -> queryBalances $ userAddresses' wallet) walletsAndBets - -- | Builds the list of wallets and their respective bets made. - -- The idea here is that if we encounter a new wallet, - -- i.e., wallet for whose we haven't yet computed value lost, - -- we calculate the total once so we can ignore other entries - -- for this wallet. - -- FIXME: very ineffective, can be simplified drastically. - walletsAndBets :: [(User, GYValue)] - walletsAndBets = go bets Set.empty [] - where - go [] _ acc = acc - go allBets@((getWallet, _, _) : remBets) set acc = - let wallet = getWallet ws - addr = userAddr wallet - in - if Set.member addr set - then go remBets set acc -- already summed - else go - remBets - (Set.insert addr set) - ((wallet := totalBets wallet allBets mempty) : acc) - - -- | Recursive functions that sums all bets for the corresponding wallet. - totalBets :: User -> [Bet] -> GYValue -> GYValue - totalBets _ [] acc = acc - totalBets wallet ((getWallet, _, bet) : remBets) acc = - totalBets wallet remBets $ - if getWallet ws == wallet - then acc <> valueNegate bet - else acc + -- \| Builds the list of wallets and their respective bets made. + -- The idea here is that if we encounter a new wallet, + -- i.e., wallet for whose we haven't yet computed value lost, + -- we calculate the total once so we can ignore other entries + -- for this wallet. + -- FIXME: very ineffective, can be simplified drastically. + walletsAndBets :: [(User, GYValue)] + walletsAndBets = go bets Set.empty [] + where + go [] _ acc = acc + go allBets@((getWallet, _, _) : remBets) set acc = + let wallet = getWallet ws + addr = userAddr wallet + in if Set.member addr set + then go remBets set acc -- already summed + else + go + remBets + (Set.insert addr set) + ((wallet := totalBets wallet allBets mempty) : acc) + -- \| Recursive functions that sums all bets for the corresponding wallet. + totalBets :: User -> [Bet] -> GYValue -> GYValue + totalBets _ [] acc = acc + totalBets wallet ((getWallet, _, bet) : remBets) acc = + totalBets wallet remBets $ + if getWallet ws == wallet + then acc <> valueNegate bet + else acc - -- | Function to verify that the wallet indeed lost by /roughly/ the bet amount. - -- We say /roughly/ as fees is assumed to be within (0, 1 ada]. - verify :: GYTxGameMonad m => [((User, GYValue), GYValue, GYValue)] -> m () - verify [] = return () - verify (((wallet, diff), vBefore, vAfter) : xs) = - let vAfterWithoutFees = vBefore <> diff - (expectedAdaWithoutFees, expectedOtherAssets) = valueSplitAda vAfterWithoutFees - (actualAda, actualOtherAssets) = valueSplitAda vAfter - threshold = 1_500_000 -- 1.5 ada - in - if expectedOtherAssets == actualOtherAssets - && actualAda < expectedAdaWithoutFees - && expectedAdaWithoutFees - threshold <= actualAda - then verify xs - else - throwAppError . someBackendError . T.pack $ - printf "For wallet %s expected value (without fees) %s but actual is %s" - (show $ userAddr wallet) - (show vAfterWithoutFees) - (show vAfter) + -- \| Function to verify that the wallet indeed lost by /roughly/ the bet amount. + -- We say /roughly/ as fees is assumed to be within (0, 1 ada]. + verify :: GYTxGameMonad m => [((User, GYValue), GYValue, GYValue)] -> m () + verify [] = return () + verify (((wallet, diff), vBefore, vAfter) : xs) = + let vAfterWithoutFees = vBefore <> diff + (expectedAdaWithoutFees, expectedOtherAssets) = valueSplitAda vAfterWithoutFees + (actualAda, actualOtherAssets) = valueSplitAda vAfter + threshold = 1_500_000 -- 1.5 ada + in if expectedOtherAssets == actualOtherAssets + && actualAda < expectedAdaWithoutFees + && expectedAdaWithoutFees - threshold <= actualAda + then verify xs + else + throwAppError . someBackendError . T.pack $ + printf + "For wallet %s expected value (without fees) %s but actual is %s" + (show $ userAddr wallet) + (show vAfterWithoutFees) + (show vAfter) -- | Runner for multiple bets. -runMultipleBets - :: GYTxGameMonad m - => BetRefParams - -> GYTxOutRef -- ^ Reference script - -> [Bet] - -> Wallets - -> m () +runMultipleBets :: + GYTxGameMonad m => + BetRefParams -> + -- | Reference script + GYTxOutRef -> + [Bet] -> + Wallets -> + m () runMultipleBets brp refScript bets ws = go bets True - where - go [] _ = return () - go ((getWallet, dat, bet) : remBets) isFirst = do - if isFirst then do + where + go [] _ = return () + go ((getWallet, dat, bet) : remBets) isFirst = do + if isFirst + then do gyLogInfo' "" "placing the first bet" void $ runPlaceBet refScript brp dat bet Nothing (getWallet ws) go remBets False @@ -282,7 +323,7 @@ runMultipleBets brp refScript bets ws = go bets True gyLogInfo' "" "placing a next bet" -- need to get previous bet utxo betRefAddr <- betRefAddress brp - GYUTxO{utxoRef} <- head . utxosToList <$> utxosAtAddress betRefAddr Nothing + GYUTxO {utxoRef} <- head . utxosToList <$> utxosAtAddress betRefAddr Nothing gyLogDebug' "" $ printf "previous bet utxo: %s" utxoRef void $ runPlaceBet refScript brp dat bet (Just utxoRef) (getWallet ws) go remBets False @@ -292,13 +333,16 @@ runMultipleBets brp refScript bets ws = go bets True -- ----------------------------------------------------------------------------- -- | Runner to build and submit a transaction that deploys the reference script. -runDeployScript - :: GYTxGameMonad m - => Integer -- ^ Bet Until slot - -> Integer -- ^ Bet Reveal slot - -> GYValue -- ^ Bet step value - -> Wallets - -> m (BetRefParams, GYTxOutRef) +runDeployScript :: + GYTxGameMonad m => + -- | Bet Until slot + Integer -> + -- | Bet Reveal slot + Integer -> + -- | Bet step value + GYValue -> + Wallets -> + m (BetRefParams, GYTxOutRef) runDeployScript betUntil betReveal betStep ws = do (params, script) <- mkScript betUntil betReveal (userPkh $ oracle ws) betStep asUser (admin ws) $ do diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs index ed250229..8a4d0e08 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -1,27 +1,31 @@ -module GeniusYield.Test.Unified.BetRef.TakePot - ( takeBetPotTests - , takeBetPotTestsClb - ) where +module GeniusYield.Test.Unified.BetRef.TakePot ( + takeBetPotTests, + takeBetPotTestsClb, +) where -import Control.Monad.Except (handleError) -import Control.Monad.Extra (maybeM) -import Data.Maybe (listToMaybe) -import Test.Tasty (TestTree, - testGroup) +import Control.Monad.Except (handleError) +import Control.Monad.Extra (maybeM) +import Data.Maybe (listToMaybe) +import Test.Tasty ( + TestTree, + testGroup, + ) -import GeniusYield.Test.Unified.BetRef.Operations -import GeniusYield.Test.Unified.BetRef.PlaceBet -import GeniusYield.Test.Unified.OnChain.BetRef.Compiled -import GeniusYield.Imports -import GeniusYield.Test.Clb -import GeniusYield.Test.Privnet.Setup -import GeniusYield.Test.Utils -import GeniusYield.TxBuilder -import GeniusYield.Types -import GeniusYield.HTTP.Errors (someBackendError) +import GeniusYield.HTTP.Errors (someBackendError) +import GeniusYield.Imports +import GeniusYield.Test.Clb +import GeniusYield.Test.Privnet.Setup +import GeniusYield.Test.Unified.BetRef.Operations +import GeniusYield.Test.Unified.BetRef.PlaceBet +import GeniusYield.Test.Unified.OnChain.BetRef.Compiled +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types takeBetPotTestsClb :: TestTree -takeBetPotTestsClb = testGroup "Take bet pot" +takeBetPotTestsClb = + testGroup + "Take bet pot" [ mkTestFor "Take bet pot" takeBetsTest , mkTestFor "Take by wrong guesser" $ mustFail . wrongGuesserTakeBetsTest @@ -31,92 +35,126 @@ takeBetPotTestsClb = testGroup "Take bet pot" -- | Our unit tests for taking the bet pot operation takeBetPotTests :: Setup -> TestTree -takeBetPotTests setup = testGroup "Take bet pot" +takeBetPotTests setup = + testGroup + "Take bet pot" [ mkPrivnetTestFor_ "Take bet pot" takeBetsTest , mkPrivnetTestFor_ "Take by wrong guesser" $ mustFailPrivnet . wrongGuesserTakeBetsTest , mkPrivnetTestFor_ "The first bet matters" $ mustFailPrivnet . badUpdatedGuessTakeBetsTest ] - where - mkPrivnetTestFor_ = flip mkPrivnetTestFor setup - -- Must fail with script execution error (which is fired in the body error auto balance). - mustFailPrivnet = handleError - (\case - GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () - e -> throwError e - ) + where + mkPrivnetTestFor_ = flip mkPrivnetTestFor setup + -- Must fail with script execution error (which is fired in the body error auto balance). + mustFailPrivnet = + handleError + ( \case + GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () + e -> throwError e + ) takeBetsTest :: GYTxGameMonad m => TestInfo -> m () -takeBetsTest TestInfo{..} = mkTakeBetsTest - 400 1_000 +takeBetsTest TestInfo {..} = + mkTakeBetsTest + 400 + 1_000 (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 - <> valueSingleton testGoldAsset 1_000) + , + ( w4 + , OracleAnswerDatum 5 + , valueFromLovelace 65_000_000 + <> valueSingleton testGoldAsset 1_000 + ) ] - 4 w2 testWallets + 4 + w2 + testWallets wrongGuesserTakeBetsTest :: GYTxGameMonad m => TestInfo -> m () -wrongGuesserTakeBetsTest TestInfo{..} = mkTakeBetsTest - 400 1_000 +wrongGuesserTakeBetsTest TestInfo {..} = + mkTakeBetsTest + 400 + 1_000 (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 - <> valueSingleton testGoldAsset 1_000) + , + ( w4 + , OracleAnswerDatum 5 + , valueFromLovelace 65_000_000 + <> valueSingleton testGoldAsset 1_000 + ) ] - 5 w2 testWallets + 5 + w2 + testWallets badUpdatedGuessTakeBetsTest :: GYTxGameMonad m => TestInfo -> m () -badUpdatedGuessTakeBetsTest TestInfo{..} = mkTakeBetsTest - 400 1_000 - (valueFromLovelace 10_000_000) +badUpdatedGuessTakeBetsTest TestInfo {..} = + mkTakeBetsTest + 400 + 1_000 + (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 - <> valueSingleton testGoldAsset 1_000) + , + ( w4 + , OracleAnswerDatum 5 + , valueFromLovelace 65_000_000 + <> valueSingleton testGoldAsset 1_000 + ) ] - 2 w2 testWallets + 2 + w2 + testWallets -- | Trace for taking bet pot. -mkTakeBetsTest - :: GYTxGameMonad m - => Integer - -> Integer - -> GYValue - -> [Bet] - -> Integer - -> (Wallets -> User) -- ^ Pot taker - -> Wallets - -> m () -mkTakeBetsTest betUntil betReveal betStep walletBets answer getTaker ws@Wallets{..} = do +mkTakeBetsTest :: + GYTxGameMonad m => + Integer -> + Integer -> + GYValue -> + [Bet] -> + Integer -> + -- | Pot taker + (Wallets -> User) -> + Wallets -> + m () +mkTakeBetsTest betUntil betReveal betStep walletBets answer getTaker ws@Wallets {..} = do (brp, refScript) <- runDeployScript betUntil betReveal betStep ws runMultipleBets brp refScript walletBets ws -- Now lets take the bet refInput <- asUser w1 $ addRefInput True (userAddr w8) (datumFromPlutusData $ OracleAnswerDatum answer) let taker = getTaker ws betRefAddr <- betRefAddress brp - GYUTxO{utxoRef, utxoValue} <- head . utxosToList - <$> utxosAtAddress betRefAddr Nothing + GYUTxO {utxoRef, utxoValue} <- + head . utxosToList + <$> utxosAtAddress betRefAddr Nothing currSlot <- slotToInteger <$> slotOfCurrentBlock let waitUntil = slotFromApi (fromInteger $ currSlot + betReveal) gyLogDebug' "" $ "waiting till slot: " <> show waitUntil - waitUntilSlot_ waitUntil - withWalletBalancesCheckSimple [taker := utxoValue] . asUser taker - . void $ takeBetsRun refScript brp utxoRef refInput + waitUntilSlot_ waitUntil + withWalletBalancesCheckSimple [taker := utxoValue] + . asUser taker + . void + $ takeBetsRun refScript brp utxoRef refInput -- | Run to call the `takeBets` operation. takeBetsRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId takeBetsRun refScript brp toConsume refInput = do - addr <- maybeM (throwAppError $ someBackendError "No own addresses") - pure $ listToMaybe <$> ownAddresses + addr <- + maybeM + (throwAppError $ someBackendError "No own addresses") + pure + $ listToMaybe <$> ownAddresses skeleton <- takeBets refScript brp toConsume addr refInput - buildTxBody skeleton >>= signAndSubmitConfirmed \ No newline at end of file + buildTxBody skeleton >>= signAndSubmitConfirmed diff --git a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs index c5fb20a4..00d1f829 100644 --- a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs +++ b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs @@ -48,7 +48,8 @@ data BetRefParams = BetRefParams , brpBetStep :: Value -- ^ Each newly placed bet must be more than previous bet by `brpBetStep` amount. } - deriving stock (Show) + deriving stock Show + -- PlutusTx.makeLift ''BetRefParams PlutusTx.unstableMakeIsData ''BetRefParams diff --git a/tests-unified/atlas-unified-tests.hs b/tests-unified/atlas-unified-tests.hs index 7dfa2f79..c0ab37f2 100644 --- a/tests-unified/atlas-unified-tests.hs +++ b/tests-unified/atlas-unified-tests.hs @@ -12,15 +12,18 @@ import GeniusYield.Test.Privnet.Setup import GeniusYield.Test.Unified.BetRef.PlaceBet import GeniusYield.Test.Unified.BetRef.TakePot - main :: IO () main = do - defaultMain $ testGroup "Emulator" - [ placeBetTestsClb - , takeBetPotTestsClb - ] + defaultMain $ + testGroup + "Emulator" + [ placeBetTestsClb + , takeBetPotTestsClb + ] withPrivnet cardanoDefaultTestnetOptionsConway $ \setup -> - defaultMain $ testGroup "Privnet" - [ placeBetTests setup - , takeBetPotTests setup - ] \ No newline at end of file + defaultMain $ + testGroup + "Privnet" + [ placeBetTests setup + , takeBetPotTests setup + ] From 4c06e78eb826b4299cb1ec5d67511841bc0d4111 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Fri, 6 Sep 2024 12:18:41 +0530 Subject: [PATCH 7/9] style(#348): handle `hlint` suggestions --- tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index f88f5c4d..ca4ed04f 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -39,7 +39,7 @@ placeBetTestsClb :: TestTree placeBetTestsClb = testGroup "Place bet" - [ mkTestFor "Simple tx" $ simpleTxTest + [ mkTestFor "Simple tx" simpleTxTest , mkTestFor "Placing first bet" firstBetTest' , mkTestFor "Multiple bets" multipleBetsTest , mkTestFor "Multiple bets - to small step" $ mustFail . failingMultipleBetsTest @@ -50,7 +50,7 @@ placeBetTests :: Setup -> TestTree placeBetTests setup = testGroup "Place bet" - [ mkPrivnetTestFor_ "Simple tx" $ simpleTxTest + [ mkPrivnetTestFor_ "Simple tx" simpleTxTest , mkPrivnetTestFor_ "Placing first bet" firstBetTest' , mkPrivnetTestFor_ "Multiple bets" multipleBetsTest , mkPrivnetTestFor' "Multiple bets - too small step" GYDebug setup $ From 5f756d9af09e02e139d00e7619d257addae0e383 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Fri, 6 Sep 2024 12:24:46 +0530 Subject: [PATCH 8/9] feat(#348): check CI for format failure --- tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index ca4ed04f..0f9f6969 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -39,7 +39,7 @@ placeBetTestsClb :: TestTree placeBetTestsClb = testGroup "Place bet" - [ mkTestFor "Simple tx" simpleTxTest + [ mkTestFor "Simple tx" simpleTxTest , mkTestFor "Placing first bet" firstBetTest' , mkTestFor "Multiple bets" multipleBetsTest , mkTestFor "Multiple bets - to small step" $ mustFail . failingMultipleBetsTest From ddecef106ae5d5442c58b08f50e472395e785025 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Fri, 6 Sep 2024 12:48:21 +0530 Subject: [PATCH 9/9] style(#348): ci test succeeded, finalised all files with fourmolu --- tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index 0f9f6969..ca4ed04f 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -39,7 +39,7 @@ placeBetTestsClb :: TestTree placeBetTestsClb = testGroup "Place bet" - [ mkTestFor "Simple tx" simpleTxTest + [ mkTestFor "Simple tx" simpleTxTest , mkTestFor "Placing first bet" firstBetTest' , mkTestFor "Multiple bets" multipleBetsTest , mkTestFor "Multiple bets - to small step" $ mustFail . failingMultipleBetsTest